|
こんにちは
検索で組んでみました。お試しを。
Sub Test_Copy()
Dim R As Range, C As Range, Ws As Worksheet
Dim Fi As Range, Ad As String
Set Ws = Worksheets("Sheet2")
With Worksheets("Sheet3")
Set R = .Range("A1", .Range("A65536").End(xlUp))
End With
With Worksheets("Sheet1")
For Each C In R
Set Fi = .Columns(1).Find(C.Value, , xlValues, xlWhole, xlPrevious)
If Not Fi Is Nothing Then
Ad = Fi.Address
Do
Set Fi = .Columns(1).FindNext(Fi)
Ws.Range("A65536").End(xlUp) _
.Offset(1).Resize(, 9).Value = Fi.Resize(, 9).Value
Loop Until Ad = Fi.Address
End If
Next C
End With
Set R = Nothing: Set Ws = Nothing
End Sub
|
|