|
こんにちは
Sheet1のB2に抽出年月、B4以下にデータとして、Sheet2に抽出するなら、
Sub test()
Dim r As Range
Dim c As Range
Dim v() As String
Dim i As Long
With Worksheets("Sheet1")
With .Range("B4", .Range("B65536").End(xlUp))
.AutoFilter Field:=1, _
Criteria1:=.Parent.Range("B2").Value
For Each r In .SpecialCells(xlCellTypeVisible)
If r.Row > 4 Then
ReDim Preserve v(0 To i)
v(i) = r(0, 1).Address
i = i + 1
End If
Next
If .Parent.AutoFilterMode = True Then _
.Parent.AutoFilterMode = False
On Error Resume Next
For i = LBound(v) To UBound(v)
Set c = .Find("コード*", .Parent.Range(v(i)), xlValues, xlPart)
If Not c Is Nothing Then
.Parent.Range(v(i), c).Copy _
Worksheets("Sheet2").Range("A65536").End(xlUp).Offset(1)
End If
Next
On Error GoTo 0
End With
End With
Erase v
End Sub
データが無い場合等のエラー処理はご自分で追加してみて下さい。
|
|