VBAでExcelのマクロを作れる方に質問です。

今、Excelのシートが複数(この場合は3つ)あるとします。
「果物シート」には、この図 http://www.fastpic.jp/images/403/7360443948.jpg のように、データが入っています。
しかし、縦列にずーっと下がっていくと、55260行目辺りにもいくつかデータがあり。http://www.fastpic.jp/images/091/9149705633.jpg
横列もずーっと見ていくと、DY~EB列にもデータが点在しています。http://www.fastpic.jp/images/815/4551680644.jpg

この際、縦軸(列)において、一番最後にデータが入ってるセルより下の行以降を全て選択して削除し。(イメージ:http://www.fastpic.jp/images/791/2139172297.jpg
同じく横軸(業)においても、一番最後にデータが入ってるセルより右の列以降を全て選択して削除する。(イメージ:http://www.fastpic.jp/images/391/1199532087.jpg

そして同じようなデータ削除を全てのシートに適用する。
(※この場合は「果物2」「果物3」シートのみになりますが、シートが数十枚に及ぶことがあるので、可能であればシート名に関係なく全シートに処理を施したいです。)

そのような処理を行うマクロを、もしご存知でしたら教えていただきたい次第です。
よろしくお願いします。

回答の条件
  • 1人5回まで
  • 登録:
  • 終了:2012/03/24 06:45:13
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Mook No.1

回答回数1314ベストアンサー獲得回数393

ポイント300pt

通常であれば下記で出来ると思いますが、

Option Explicit

Sub DeleteEmptyAreaSimple()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim lastCol As Long
    For Each ws In Worksheets
        With ws
            lastRow = ws.UsedRange.Rows.Count
            lastCol = ws.UsedRange.Columns.Count
        
            If lastCol < Columns.Count Then
                .Range(.Cells(1, lastCol + 1), .Cells(1, Columns.Count)).EntireColumn.Delete
            End If
            
            If lastRow < Rows.Count Then
                .Range(.Cells(lastRow + 1, "A"), .Cells(Rows.Count, "A")).EntireRow.Delete
            End If
        End With
    Next
End Sub

シートがデータのない範囲まで、使用している範囲と認識していることも有るので、
実際のデータを確認して範囲を削除する例です。

Option Explicit

Sub DeleteEmptyArea()
    Dim ws As Worksheet
    For Each ws In Worksheets
        cleanupWS ws
    Next
End Sub

Sub cleanupWS(ws As Worksheet)
    Dim lastRow As Long
    Dim maxLastRow As Long
    Dim maxLastCol As Long
    
    With ws
        maxLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        maxLastCol = 1
        
        Dim c As Long
        For c = 2 To Columns.Count
            If Application.WorksheetFunction.CountA(.Columns(c)) <> 0 Then maxLastCol = c
            lastRow = .Cells(Rows.Count, c).End(xlUp).Row
            If lastRow > maxLastRow Then maxLastRow = lastRow
        Next
    
        If maxLastCol < Columns.Count Then
            .Range(.Cells(1, maxLastCol + 1), .Cells(1, Columns.Count)).EntireColumn.Delete
        End If
        
        If maxLastRow < Rows.Count Then
            .Range(.Cells(maxLastRow + 1, "A"), .Cells(Rows.Count, "A")).EntireRow.Delete
        End If
    End With
End Sub
id:moon-fondu

うまく削除できました!
ありがとうございます(^_^;)

2012/03/24 06:45:02
id:Mook

無事にできたようでよかったです。

2012/03/24 18:17:12

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません