空白や関数がある複数シートを一覧にまとめたい

いつもお世話になっております。
件名を間違えて記載していたので、再度質問させていただきます。
-----------------------------------------------
関数や空白がいくつもある複数のシートを一枚にまとめたいので
アドバイスを頂けたらと思います。

仮に図のようなシートが店舗毎に複数枚あったとして、
シート名は【小樽店3月分】【青森支店4月分】など、最後に必ず【○○店××分】とあります。
シートは120枚ぐらいあり、今後も増える予定です。
データは実際には1500行前後あり、P列まであります
そこでC列が空白のものを非表示にし、それを【一覧（Worksheets(200）】シートにまとめたいと思います。
最初は表に空白と関数があるため、下記のように組んでいたのですが

Macro まとめ ()
application run.コピー＆値として貼り付け
application run.C列が空白の場合行ごと削除
application run.一覧にまとめる

行数が多いせいか、【コピー＆値として貼り付け】の際に時間がかかり、
過去の質問（https://oshiete.goo.ne.jp/qa/7038820.html）を参考にし、
以下のように作りなおしました。

Sub 一覧表示() 'この行から
Dim i, j, k As Long
i = Worksheets(200).Cells(Rows.Count, 1).End(xlUp).Row
If i > 2 Then
Range(Worksheets(200).Cells(3, 1), Worksheets(200).Cells(i, 7)).ClearContents
End If
Application.ScreenUpdating = False
For k = 1 To 120 'Sheet1～Sheet120まで
For i = 3 To Worksheets(k).Cells(Rows.Count, 1).End(xlUp).Row '3行目～最終行まで
For j = 1 To 7 'A列～G列まで
If Worksheets(k).Cells(i, 7) <> "" Then
Worksheets(200).Cells(Rows.Count, j).End(xlUp).Offset(1) = _
Worksheets(k).Cells(i, j)
End If
Next j
Next i
Next k
Application.ScreenUpdating = True
End Sub 'この行まで

しかしこれだとC列以外の空白が詰めて貼り付けされてしまうため、データの内容が狂ってしまいました。
そこで、他の回答を参考に下記を作りましたが、今度は【Selection.AutoFilter】の段階でエラーにり、
またシートが120もあるので全部書くのは難しいかと思い、諦めてしまいました。

'貼り付け
　 Sheets("小樽店3月分").Select
Range("A4:G1000").Select　
Selection.AutoFilter
ActiveSheet.ListObjects("小樽店3月分").Range.AutoFilter Field:=3, Criteria1:="<>"
Selection.Copy
Sheets("一覧").Select
Range("A3").Select
ActiveSheet.Paste
Sheets("青森支店4月分").Select
Range("A4:G1000").Select　
Selection.AutoFilter
ActiveSheet.ListObjects("青森支店4月分").Range.AutoFilter Field:=3, Criteria1:="<>"
Selection.Copy
Sheets("一覧").Select
ActiveCell.End(xlDown)).OFFSET(1,-3).Select
ActiveSheet.Paste

他に何か良い手立てはないでしょうか。
どうぞよろしくお願いします。

No.3 ベストアンサー 回答者： fujillin 回答日時： 2018/03/02 13:58

こんにちは

他の方も質問なさっていますが、いろいろわからないところがあるので、勝手に決め打ちしてみました。

・コードだとタイトル行は2行に見えるけれど、図では1行っぽいので1行に固定
・A列で最終行を判定しているようですが、図ではA列にも値のない行が存在するようなので（最終行はとれない）、効率が悪いけれど、usedRangeで対象範囲を決めています。
・コピーは「値のみペースト」で行います。（関数式があるのかないのか不明なので）
・C列が空白の行はコピーしない。（関数の計算結果が空白の場合を含む）
　（1セルずつチェックしていますが、C列に関数式がなければもっと簡単になります）
・C列の値がエラー値の場合は、コピーの対象とする

※ コピー対象はG列まででも良さそうな感じですが、とりあえず行全体をコピーするようにしてあります。
※ 上述のように、usedRangeを用いていますので、少々効率が悪いです。
※ 処理方法としては、元のシート内の行を一旦全部集計シートにコピーしてから、不要な行（C列が空白）を削除するという手順にしています。

Constで設定している、「集計用シート名」、「空白チェック対象列番号」、「処理対象シートの最大数」などを設定し直してください。
（最初は2シートくらいで試してみて、それから増やすのが吉でしょう）

Sub Sample()
Dim dstS As Worksheet
Dim dstR As Range, tmp As Range, delR As Range
Dim shtN As Long, pointer As Long
Dim rw As Long, r As Long

Const dstSheet = "Sheet15" '←集計用シートのシート名
Const cClmn = 3 '空白をチェックする列番号
Const shtMax = 2 '処理の対象とするシートの最大番号


Set dstS = Worksheets(dstSheet)
dstS.UsedRange.Offset(1).EntireRow.Delete

For shtN = 1 To shtMax
　pointer = dstS.UsedRange.Rows.Count + 1
　rw = Worksheets(shtN).UsedRange.Rows.Count
　If rw > 1 Then
　　Worksheets(shtN).Range("A2").Resize(rw - 1).EntireRow.Copy
　　dstS.Cells(pointer, 1).PasteSpecial Paste:=xlPasteValues
　　Set delR = Nothing
　　For r = pointer To pointer + rw - 1
　　　Set tmp = dstS.Cells(r, cClmn)
　　　If Not IsError(tmp.Value) Then
　　　　If tmp.Value = "" Then
　　　　　If delR Is Nothing Then Set delR = tmp Else Set delR = Union(delR, tmp)
　　　　End If
　　　End If
　　Next r
　　If Not (delR Is Nothing) Then delR.EntireRow.Delete
　End If
Next shtN
End Sub

この回答へのお礼

私の拙い質問に丁寧に答えていただき、ありがとうございました！
皆様にベストアンサーを差し上げたいのですが
fujillinさんのコードを少し変更して処理が出来たのでfujillinさんをベストアンサーにしたいと思います。
ありがとうございました！

お礼日時：2018/03/03 00:29

No.4 回答者： 白亜気 回答日時： 2018/03/02 15:09

今コードを書いて示せないのですが、つぎの方法でどうでしょう。

条件：
Sheets(1)～Sheets(200)があるWorkbookに存在する。
Sheets(200)はまとめ表に使って、使い捨てにする（以前のデータは書き換えられて構わない）
Sheets(1 )～Sheets(120)は、同じフォーマットで作られている。
Sheets(200)に転記するのは、Sheets(1)～Sheets(120)の3行目～データのある最終行までで、C列が空白ではない行の（A列～G列）であり、H列を含め右側の列データは転記しない。
Sheets(200)に転記するにあたって、データは空白行を置かず、行を詰めてよい。またSheets(1)～Sheets(120)の順になっていれば、どのSheetsからの転記であるか区分などを表記追加する必要はない。

やり方：
Sheets(200)の3行目以下をすべてクリアする。
次をSheets(1)～Sheets(120)までForループで繰り返す。
　　Sheets(200)の最終行+1を獲得
　　Sheets(i)の最終行のRowを獲得
　　Sheets(i)の最終行Rowが２以下の場合は、次のSheetに進む
　　Sheets(i)のRange(A3～G最終行)をSheets(200)の最終行+1のAセル位置に一気に一括コピーする（やり方、コードがわからなかったら、調べてください）
NextでForを回す。
　　☆　ここまでで、Sheets(1)～Sheets(120)の必要データはすべてSheets(200)に転記されます。C列データ空白の行も転記されます。1つ1つのセルを転記するより速いです、コードも簡単です。1行づつ転記するより速いです。


この先もコードを書いてマクロ実行の中でいいのですが、手動でやってみます。
Sheets(200)のH列より右は空白のはずです。
Sheets(200).H3のセルに　=(C3>"")*1 　と数式を入れて、H3セルの右下角をダッブルクリックして最終行まで数式をコピーさせます。０か１かが表示されます。H3のセルを選択し、Ctrl+Shift+左、Ctrl+Shift+ 下で、全データ領域を選択した状態で、並べ替えを（H列優先・降順）で実行します。
これで、C列が空白の行は下方に移動します。
上には、必要な全データが希望の順で並んでいます。
H列や、C列が空白の行を削除するのは簡単だと思います。

No.2 回答者： tatsu99 回答日時： 2018/03/02 12:56

No1です。

＞そこでC列が空白のものを非表示にし、それを【一覧（Worksheets(200）】シートにまとめたいと思います。
これを見落としていました。
結局、あなたがコピーしたい行とは、
「C列が空白でない行」ということでしょうか？
その行のA列～I列をコピーしたいということでしょうか？

No.1 回答者： tatsu99 回答日時： 2018/03/02 11:18

補足要求です。

１．コピー対象となる行は、どのような行なのですか。
①G列が空白でない行
これがあなたの提示したマクロの内容から読み取れる行です。

②A列～G列の何れかが空白でない行（A列～G列が全て空白ならコピーしない、以外はコピー）
これがあなたの提示したマクロを拡大解釈して想定した行です。

③A列～I列の何れかが空白でない行（A列～I列が全て空白ならコピーしない、以外はコピー）
これがあなたが提示した画像から読み取れる行です。