オートフィルター抽出時データ無い列、行を非表示

こんばんは、下記のURLで教えて頂いた方法で大きなマトリックス(A1:CR6000)が出来ました

http://oshiete.goo.ne.jp/qa/7463440.html

質問：

タイトルは、行１、行２とタイトルが入っていて、データ領域（A3:CR6000)まであり、データ量は増えて行きます。

オートフィルターで、A列データ抽出時、B3:CR***範囲内でデータの無い列、行があります、
タイトル列も含めて、列、行を非表示にする事は可能でしょうか？ご教授下さい

No.1 ベストアンサー 回答者： tom04 回答日時： 2012/05/09 22:20

こんばんは！

前回投稿した者です。

実は投稿後気になっていたコトが今回の質問だと思います。
前回のコードでは1行に1データ表示になってしまいますので、
あまりに空白セルが多くなりすぎているのではないかと・・・

もう一度コードを載せておきます。
今回もAlt+F11キー　→　画面左下の「This Workbook」をダブルクリックして
↓のコードをコピー＆ペーストしてマクロを試してみてください。

※　単純に空白セルを削除するだけなら簡単なのですが、
Sheet2のB列以降に1データでもあればその行の空白セルは残しておく！
という作業が必要になると思います。

そこで今回はSheet3を作業用のSheetとして使っていますので、
Sheet見出しには「Sheet3」まで表示しておいてください。
Sheet3はまっさらなSheetだとします。

Sub test2()
Dim i, j, k, L, M As Long
Dim ws1, ws2, ws3 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")
Application.ScreenUpdating = False
k = ws2.Cells(Rows.Count, 1).End(xlUp).Row
j = ws2.Cells(2, Columns.Count).End(xlToLeft).Column
If k > 2 Then
ws2.Rows(3 & ":" & k).ClearContents
End If
If j > 1 Then
Range(ws2.Cells(2, 2), ws2.Cells(2, j)).ClearContents
End If
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(ws2.Rows(2), ws1.Cells(i, 3)) = 0 Then
ws2.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1) = ws1.Cells(i, 3)
End If
If WorksheetFunction.CountIf(ws3.Columns(1), ws1.Cells(i, 1)) = 0 Then
L = L + 1
ws3.Cells(L, 1) = ws1.Cells(i, 1)
End If
Next i
j = ws2.Cells(2, Columns.Count).End(xlToLeft).Column
Range(ws2.Cells(2, 2), ws2.Cells(2, j)).Copy Destination:=ws3.Cells(1, 3)
For L = 1 To ws3.Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To ws3.Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If ws1.Cells(i, 1) = ws3.Cells(L, 1) And ws1.Cells(i, 3) = ws3.Cells(1, j) Then
ws3.Cells(Rows.Count, j).End(xlUp).Offset(1) = ws1.Cells(i, 2)
End If
Next i
Next j
M = ws3.UsedRange.Rows.Count
j = ws3.Cells(1, Columns.Count).End(xlToLeft).Column
Range(ws3.Cells(2, 2), ws3.Cells(M, 2)) = ws3.Cells(L, 1)
Range(ws3.Cells(2, 2), ws3.Cells(M, j)).Cut Destination:= _
ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next L
For k = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
If WorksheetFunction.CountA(ws2.Rows(k)) = 1 Then
ws2.Rows(k).Delete
End If
Next k
ws3.Cells.Clear
Application.ScreenUpdating = True
End Sub

※　For～Nextを多用していますので、時間がかかるかもしれません。
※　質問では「タイトル行・列も含めて非表示・・・」となっていますが、タイトル行はそのままにしています。

お役に立ちますかね？m(_ _)m

この回答へのお礼

tom04さん　いつもお世話になります、有り難うございます早速実施した所、思い通りの物が出来ました、ありがとうございました。

お礼日時：2012/05/10 06:09