Excel 2007 マクロ 特定条件の抽出方法

質問

Excel 2007 マクロ作成について質問させていただきます。

Sheet1に下記2つの表があります。
表の内容を変更せずに（列を追加する等）
特定条件を別Sheet2にコピーして貼り付けたいと思います。
<くだもの在庫表>
型番 商品名 産地 本数
AA-1 りんご 国産 1
AA-2 なし 外国産 4
VB-3 ばなな 外国産
<野菜在庫表>
型番 商品名 本数
HU-3 きゅうり 5
LO-7 いも
LLU-89 だいこん 3

<条件>
本数が空白以外の行をコピーしてSheet2に貼り付けます。
結果イメージは画像をご参照ください。
2つの表の列数が異なるため、ピボットテーブルを作成して
フィルタオプションで抽出することは難しいとおもいます。
どのようなマクロになりますでしょうか。

アドバイスよろしくお願いいたします。

回答No.1

keithin · ベストアンサー

作成例：
Sub macro1()
　Dim a() As Range
　Dim i, h
　ReDim a(Application.WorksheetFunction.CountIf(Worksheets("Sheet1").UsedRange, "本数"))
　Set h = Cells.Find(what:="本数", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows)

　For i = 0 To UBound(a) - 1
　　Set a(i) = h
　　Set h = Cells.FindNext(h)
　Next i
　Set a(i) = Cells.SpecialCells(xlCellTypeLastCell).Offset(2)

　For i = 0 To UBound(a) - 1
　　a(i).Offset(-1).EntireRow.Copy Destination:=Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Offset(1).End(xlToLeft)
　　With a(i).Resize(a(i + 1).Row - a(i).Row - 1, 1)
　　　.AutoFilter field:=1, Criteria1:="<>"
　　　.EntireRow.Copy Destination:=Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Offset(1).End(xlToLeft)
　　　ActiveSheet.AutoFilterMode = False
　　End With
　Next i

　Worksheets("Sheet2").Range("1:1").Delete shift:=xlShiftUp

End Sub

＃そもそも元のシート１の作り方が，上と下で表が違うみたいな変な具合なのでここまで面倒なことになっているのですから，その困り事の根本原因になっているシート１の様子を，まず先に正しく具体的に画像で情報提供してください。
それと。まず回答された内容をよく吟味してその通りにやってみて，出来なかったら出来なかった様子を具体的に挙げて，それで返答を書くようにしてください。

お礼

ご回答ありがとうございました。問題なく解決できました。今後は質問する際の情報について、注意したいと思います。ご回答頂きましたマクロの一文一文を書籍やサイトで調べて勉強します。