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

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

解決済みの質問

同じ様式の表の複数シートから行ごと抽出

A2:K12の範囲に表がある全く同じ様式のシートが複数あります。
特定の条件が満たされた行を全て別シートに抽出したいです。
1列目と2列目とX列目(これは集計のA1セルに入った値を参照)が空白でない行を全て抽出したいです。1列目と2列目は1行目から順番に埋まっているのですが、X列目は空白になっているものと空白でないものが混在しています。
たとえば、Xが10列目のときは、Aさん、Bさん、Cさん、Dさん、Eさんの行が抽出されるようにしたいです。
VBAのコードを自力で書けないので、よろしくお願いします。

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

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

QNo.9601064

すぐに回答ほしいです

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

こうでしょうか?

Sub Sample1()

 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
   For RCnt = 2 To 12
    If ((.Sheets(shCnter).Cells(RCnt, 1).Value <> "") And _
      (.Sheets(shCnter).Cells(RCnt, 2).Value <> "") And _
      (.Sheets(shCnter).Cells(RCnt, PicColNum).Value <> "")) Then
     .Sheets(shCnter).Rows(RCnt).Copy .Sheets(PutShNum).Rows(PutRCnt)
     PutRCnt = PutRCnt + 1
    End If
   Next RCnt
  Next shCnter
 End With

End Sub

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

お礼

ご回答ありがとうございます。

投稿日時 - 2019-03-27 20:30:16

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

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

回答(2)

ANo.1

【参考意見】

 当方、先日までエクセルは開いたことも操作したこともない70歳になる爺です。ですから、エクセルのVBAなんて見たことも聞いたこともないド素人。その点を踏まえた私の回答を一瞥ください。

 質問の案件ですが、これは、(ある種のツールを使えば)VBAコードを書かずとも可能かと思います。でも、問題は、そのツールのソースコードの受け渡しの手段。多分、OKWaveが許可する行数では足りないでしょう。少なくとも、A4で7~8ページにはなるでしょうから・・・。

 一体、そのようなツールを使えば良いのかは、私のプロフィールで公開しているブログをチラリと覗いてください。

 一切のVBAコードを書かずとも可能・・・と言うことは、逆に言えば、《VBAコードを書かずとも可能にする命令文を書ける》と言うことが要求されます。なお、ブログ記事《No.16》で提示しているマクロぐらいは書けることは必要です。

Sub Test1()
  Dim strSQL0 As String
  Dim strSQL1 As String
  Dim strSQL2 As String
  
  strSQL1 = "SELECT * FROM [Sheet10$A1:C3] WHERE Len([Sheet10$A1:C3].列2 & '') >0"
  strSQL2 = "SELECT * FROM [Sheet11$A1:C3] WHERE Len([Sheet11$A1:C3].列2 & '') >0"
  strSQL0 = strSQL1 & " UNION " & strSQL2
  
  Call SQLWriter(strSQL0, "Sheet12$A1")
End Sub

Sub Test2()
  Dim strSQL1 As String
  Dim strSQL2 As String
  
  strSQL1 = "SELECT * FROM [Sheet10$A1:C3] WHERE Len([Sheet10$A1:C3].列2 & '') >0"
  strSQL2 = "SELECT * FROM [Sheet11$A1:C3] WHERE Len([Sheet11$A1:C3].列2 & '') >0"
  
  Call SQLWriter(strSQL1, "Sheet12$A1")
  Call SQLWriter(strSQL2, "Sheet12$A1;ADD")
End Sub

 なお、マクロのTest1()とTest2()の実行結果は、微妙に違います。まあ、こういうやり方もあるってことです。

投稿日時 - 2019-03-27 19:29:45

お礼

ご回答ありがとうございます。

投稿日時 - 2019-03-27 20:30:25

あなたにオススメの質問