複数シートから空白ではない行をすべて抽出

質問

タイトル行A1:D1、データの中身は、A2:D11の全く同じ様式のシートが複数あります。シート名はバラバラです。
全シートの空白ではない行を全て別の集計シートに抽出したいです。
空白行は抽出しません。
これを関数でどのようにつくればよいのでしょうか？
関数で無理ならVBAでお願いします。

回答No.2

msMike · ベストアンサー

》 空白行は抽出しません。
なら、邪魔臭い12行目も抽出すると？

回答No.6

watabe007

参考に
Sub Test()
　Dim sh As Worksheet
　Dim flg As Boolean
　Dim LastRow As Long
　For Each sh In ActiveWorkbook.Worksheets
　　If sh.Name = "集計" Then
　　　flg = True
　　ElseIf flg = True Then
　　　LastRow = Sheets("集計").Cells(Rows.Count, "A").End(xlUp).Row + 1
　　　sh.Range("A2:D" & sh.Cells(Rows.Count, "D").End(xlUp).Row).Copy _
　　　Sheets("集計").Cells(LastRow, "A")
　　End If
　Next
End Sub

回答No.5

HohoPapa

>最後のシートのものしか転記されないです。
当方で確認すると期待通り動作します。
複写元シートの２行目が空欄ということはないんですね？

もし、データの埋まる可能性のある行が２行目から１１行目までで
かつ、上詰めでデータが埋まっていないのであれば、
Sub Sample2()　を使ってみてください。

お礼

ご回答ありがとうございます。
こちらの手違いでエラーが出ていました。
もう一度コードを読むと意味がわかったので、解決しました。本当にありがとうございます。

回答No.4

HohoPapa

別案を。

集計元のシートたちは３枚目以降、すべてのシート。
空白かどうかは
Ａ列、Ｂ列ともに空欄ではない
という条件でいいですか。

また、集計元のシートの対象範囲は
必ず２行目から１１行目までで
かつ、途中に空行があるのなら
以下のコードでいかがでしょうか。

Option Explicit

Sub Sample2()

　Dim GetShe As Worksheet
　Dim PutShe As Worksheet
　Dim SheCnt As Long
　Dim RowCnt As Long
　Dim PutRowCnt As Long

　SheCnt = ThisWorkbook.Sheets.Count
　Set PutShe = ThisWorkbook.Sheets("集計")

　PutRowCnt = 1
　For SheCnt = 3 To SheCnt
　　Set GetShe = ThisWorkbook.Sheets(SheCnt)
　　For RowCnt = 2 To 11
　　　If ((GetShe.Cells(RowCnt, 1) <> "") And _
　　　　 (GetShe.Cells(RowCnt, 2) <> "")) Then
　　　　PutRowCnt = PutRowCnt + 1
　　　　GetShe.Rows(RowCnt).Copy PutShe.Rows(PutRowCnt)
　　　End If
　　Next RowCnt
　Next SheCnt

End Sub

お礼

ご回答ありがとうございます。
こちらの手違いでエラーが出ていました。
別バージョンも示していただき勉強になります。

回答No.3

HohoPapa

集計元のシートたちは３枚目以降、すべてのシート。
空白かどうかは
Ａ列、Ｂ列ともに空欄ではない
という条件でよければ
以下のコードでいかがでしょうか。

Option Explicit

Sub Sample()

　Dim GetShe As Worksheet
　Dim PutShe As Worksheet
　Dim SheCnt As Long
　Dim RowCnt As Long
　Dim ColCnt As Long
　Dim PutRowCnt As Long

　SheCnt = ThisWorkbook.Sheets.Count
　Set PutShe = ThisWorkbook.Sheets("集計")

　PutRowCnt = 1
　For SheCnt = 3 To SheCnt
　　Set GetShe = ThisWorkbook.Sheets(SheCnt)
　　RowCnt = 2
　　Do
　　　If ((GetShe.Cells(RowCnt, 1) <> "") And _
　　　　 (GetShe.Cells(RowCnt, 2) <> "")) Then
　　　　PutRowCnt = PutRowCnt + 1
　　　　GetShe.Rows(RowCnt).Copy PutShe.Rows(PutRowCnt)
　　　Else
　　　　Exit Do
　　　End If
　　　RowCnt = RowCnt + 1
　　Loop
　Next SheCnt

End Sub

※私なら加えて、
集計シートの５列目に
集計元シートのシート名を格納します。

お礼

ご回答ありがとうございます。
こちらの手違いでエラーが出ていました。
もう一度コードを読むと意味がわかったので、解決しました。本当にありがとうございます。

補足

ご回答ありがとうございます。
最後のシートのものしか転記されないです。
例えば、1つ目のシートの転記で集計シート2行目から10行目まで使った場合、2つ目のシートの転記先は集計シート11行目からにしないといけないと思います。ご回答いただいたコードでは、コピペしたものが上書きされてしまい、最終シートのものしか残らなくなると思います。少しは読めても自分ではコードが書けないので、もしよろしければお願いします。

回答No.1

中京区 桑原町（@l4330）

私なら手動でします
1）京都のシートに移動
2）A2をクリックShftとCtrlを押しながら矢印キーの下、右と押す
3）Ctrl＋C
4）集計シートを選択しA2をマウスでクリックしてEnter
・・・（これで京都シートの空白でない行がコピーされる）
5）大阪のシートを選択し2～4を繰り返す、ただし集計シートではA2出なくコピー済みの次の行をクリック
大阪シートが終われば他のシートも同様に行う
47都道府県全てのシートがあっても数分で終わります。

補足

単純化したモデルです。
実際はもっと面倒なので、手動は困難です。