複数シートからの行 抽出改良バージョン

質問

https://okwave.jp/qa/q9586463.html
↑この質問の回答を頂いた者ですが、改良したいと思っています。
もしよろしければ、ご回答お願いいたします。(前回は操作ミスでベストアンサーにできず、申し訳ありませんでした。)

この質問では、「各シートの表が上から順番に埋まっていること」を前提に「1列目と2列目が空白でない行を全て抽出する」ことになっています。つまり空白行が出た時点で次のシートへ抽出対象が移ります。

改良バージョンが「各シートの1列目と2列目とX列目(A1セルの値を代入)が空白でない行を全て抽出」です。問題がX列目は空白の行と空白になっていない行が混在していることで、X列目が空白でもそのシートの2列目にデータが入っている最後の行(2列目は途中に空白はない)まで調べて抽出する必要があります。

新しく添付した画像の例では、Xが10列目のときは、橋本、浜崎、根本、末吉、恩田の行が抽出されるようにしたいです。

コードを改良していただけませんか？

この投稿のマルチメディアは削除されているためご覧いただけません。

回答No.1

HohoPapa · ベストアンサー

こうでしょうか？

Option Explicit

Sub Sample()

　Dim shCnter As Long
　Dim PutRCnt As Long
　Dim RCnt As Long
　Dim PicColNum As Long

　Const PutShNum = 1　'集計先シート番号
　Const GetShNumS = 2 '集計元シート群の先頭シート番号
　Const GetShNumE = 4 '集計元シート群の末尾シート番号

　PicColNum = ThisWorkbook.Sheets(PutShNum).Cells(1, 1).Value

　With ThisWorkbook
　　PutRCnt = 2
　　For shCnter = GetShNumS To GetShNumE
　　　RCnt = 2
　　　Do
　　　　If .Sheets(shCnter).Cells(RCnt, 2).Value = "" Then Exit Do
　　　　If ((.Sheets(shCnter).Cells(RCnt, 1).Value <> "") And _
　　　　　　(.Sheets(shCnter).Cells(RCnt, PicColNum).Value <> "")) Then
　　　　　.Sheets(shCnter).Rows(RCnt).Copy .Sheets(PutShNum).Rows(PutRCnt)
　　　　　PutRCnt = PutRCnt + 1
　　　　End If
　　　　RCnt = RCnt + 1
　　　Loop
　　Next shCnter
　End With

End Sub

お礼

ご回答ありがとうございます！
本当に助かりました。