|
▼たけちゃんまん さん
フィルターオプションやオートフィルター処理が適していると思います。
以下はフィルターオプション。
元シート名や転記先シート名は実際のものに変更してください。
Sub Sample() 'フィルターオプション
Dim cols As Long
Dim r As Range
Dim shT As Worksheet
Application.ScreenUpdating = False
Set shT = Sheets("Sheet2") '転記シート
shT.UsedRange.ClearContents
With Sheets("Sheet1") '元シート
cols = .UsedRange.Columns.Count
Set r = .Range("A1", .UsedRange).Offset(1)
.Cells(1, cols + 2).Value = .Range("I2").Value '抽出項目タイトル
.Cells(2, cols + 2).Resize(3).Value = WorksheetFunction.Transpose(Array("'=b001", "'=b002", "'=b003"))
r.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Cells(1, cols + 2).CurrentRegion, _
CopyToRange:=shT.Range("A1"), Unique:=False
.Cells(1, cols + 2).CurrentRegion.Clear
End With
shT.Select
End Sub
|
|