みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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

マルチメディアファイルは削除されたか見つかりません。

投稿日時 - 2019-03-27 17:42:19

QNo.9601069

困ってます

質問者が選んだベストアンサー

こうでしょうか?

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

投稿日時 - 2019-03-27 20:20:55

お礼

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

投稿日時 - 2019-03-27 20:29:26

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問