特定の数値があるセルと、そのセルがある行の左端から３列目までを別シートに抽出したいです。 下の画像で

特定の数値があるセルと、そのセルがある行の左端から３列目までを別シートに抽出したいです。
下の画像ですと、D列からI列の中で『2017/06』が含まれるセルと、そのセルがある行のA列からC列を別シートに抜き出して『2017/06』分の表を作りたいです。
また、９行目からも新しく氏名、商品、回数などデータを足していく予定です。
データ量が膨大なので、作業の効率化を図りたいです。

お手数おかけしますが、どうぞよろしくお願いいたします。

No.1 回答者： Sand_Dollar 回答日時： 2017/09/23 18:25

画像のシート名（元データのあるシート）を「データ」、結果を表示するシート名を「抽出」とします。

抽出シートの1行目にはA1～C１に 氏名、商品、回数 という見出しがあるとします。
抽出する月はその都度指定させる方法としての1例ですが、
VBAの標準モジュールに以下のコードをコピーして、これを実行すれば抽出できます。


Sub データ抽出()

Dim mySh1 As Worksheet
Dim mySh2 As Worksheet
Dim arrData(1 To 9) As Variant
Dim Asp As String
Dim RowCount1 As Long
Dim RowCount2 As Long
Dim MatchFLG As Boolean
Dim I As Integer
Dim J As Integer

Set mySh1 = Worksheets("データ")
Set mySh2 = Worksheets("抽出")

'抽出シートを1行目を残してクリアする
RowCount2 = mySh2.Cells(Rows.Count, "A").End(xlUp).Row
If RowCount2 > 1 Then
　　mySh2.Rows("2:" & RowCount2).Delete
End If

'条件にマッチするデータを検索
RowCount1 = mySh1.Cells(Rows.Count, "A").End(xlUp).Row
Asp = InputBox("抽出日")

For I = 4 To RowCount1
　　MatchFLG = False
　　For J = 3 To 8
　　　If Format(mySh1.Range("A" & I).Offset(0, J), "yyyy/mm") = Asp Then
　　　　　MatchFLG = True
　　　End If
　　Next J
　　If MatchFLG Then
　　　 GoSub DataSet
　　End If
Next I

GoTo subEND

'抽出シートにデータを書き込む
DataSet:
　　RowCount2 = mySh2.Cells(Rows.Count, "A").End(xlUp).Row
　　mySh2.Range("A" & RowCount2 + 1).Offset(0, 0) = mySh1.Range("A" & I).Offset(0, 0)
　　mySh2.Range("A" & RowCount2 + 1).Offset(0, 1) = mySh1.Range("A" & I).Offset(0, 1)
　　mySh2.Range("A" & RowCount2 + 1).Offset(0, 2) = mySh1.Range("A" & I).Offset(0, 2)
Return

subEND:
　　Set mySh1 = Nothing
　　Set mySh2 = Nothing
　　MsgBox "END"

End Sub

この回答へのお礼

Sand_Dollar様
ご回答いただきありがとうございます！
回答のつづきが何故かすぐに見れなくて返信が遅くなりすみませんm(._.)m
早速、明日会社のパソコンで出来るかいただいたコードを入れてみたいとおもいます。
非常に困っていたので助かります！！！

お礼日時：2017/09/26 21:23