| |
シートを追加してそこのA列に「抽出リスト」を書いておく
というばあいは、こんな風になります
シートは
> Set WS1 = Worksheets("Sheet1")
> Set WS2 = Worksheets("抽出")
> Set WS3 = Worksheets("抽出リスト")
と変数にしていますので、
シート名を環境に合わせてください。
（結合セルでは Copyで転記できないので、
先範囲.Value = 元範囲Value
としています）
Sub マッチング2()
Dim WS1 As Worksheet, WS2 As Worksheet, WS3 As Worksheet
Dim 検索範囲 As Range, 該当セル As Range
Dim FirstHitRow As Long
Dim 転記先行 As Long '最初にヒットした行番号
Dim tbl As Variant, v As Variant
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("抽出")
Set WS3 = Worksheets("抽出リスト")
With WS1 '「検索範囲」は A列
Set 検索範囲 = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
End With
転記先行 = 5 '「転記先行」はO列 5行目から
With WS3
tbl = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Value 'A列 抽出データ
End With
For Each v In tbl
Set 該当セル = 検索範囲.Find(v, , xlFormulas, xlWhole)
If Not 該当セル Is Nothing Then '該当ｾﾙが見つかった場合は
FirstHitRow = 該当セル.Row '最初にヒットした行番号
Do
WS2.Cells(転記先行, 3) = 該当セル() 'C列に上書き
CopyLine 該当セル, WS2.Cells(転記先行, 15) '21列をコピー
転記先行 = 転記先行 + 2 '転記先行に2を加算する。
Set 該当セル = 検索範囲.FindNext(該当セル) '次を検索
Loop While 該当セル.Row <> FirstHitRow
End If
Next
End Sub
Private Sub CopyLine(該当セル As Range, 転記先 As Range) '◆変更
転記先.Resize(, 21).Value = 該当セル.Offset(, 1).Resize(, 21)()
End Sub
|
|
kanabun
- 12/8/8(水) 17:07 -
