異なるシート間の検索を繰返しマッチした行を他のシートに転記する

質問

シート１のG列に検索値がありシート２のB列に検索対象の数値がありますシート１のレコードは500件前後でシート２のレコードは1000件前後ありますシート１の検索値でシート２にマッチしたもの、しなかったものを別々のシートにコピーするマクロを作成しているのですがVLOOKUPの関数では手に負えませんでしたマクロをかじり始めて10日ですがよろしくお願いします。シート１はA列からI列までコピーするデータがあります。シート１と２の件数は毎回変わります。

回答No.2

papayuka · ベストアンサー

仮に
シート１のA2:I1000データにデータがある。
シート２のB2:B100に検索値がある。
（先頭行はそれぞれタイトル）

として、シート１の空いている K2 に

=MATCH(G2,Sheet2!$B$2:$B$100,0)

といれ、下にコピーします。
見つからない行は #N/A となるのでオートフィルタで抽出すれば出ます。

マクロで書くとたいそうな処理になってしまいました。
IV列を作業列にしています。
試すのはテスト環境で。

Sub Test1()
Dim tws As Worksheet, fws As Worksheet, LRow As Long
Dim ws As Worksheet, myMatch, s As String
Set tws = Worksheets("Sheet1")
Set fws = Worksheets("Sheet2")
LRow = fws.Range("B65536").End(xlUp).Row
s = "=Match(G2," & fws.Name & "!$B$2:$B$" & LRow & ",0)"
With tws
　　LRow = .Range("G65536").End(xlUp).Row
　　.Range("IV1") = "Temp"
　　.Range("IV2:IV" & LRow) = s
　　myMatch = Array("<>#N/A", "#N/A")
　　For i = 0 To 1
　　　　.Range("IV1").AutoFilter
　　　　.Range("IV1").AutoFilter 1, myMatch(i)
　　　　.Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
　　　　Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
　　　　ws.Range("A1").PasteSpecial xlPasteAll
　　　　ws.Range("A1").Select
　　　　Application.CutCopyMode = False
　　Next i
　　.Range("IV1").AutoFilter
　　.Range("IV1:IV65536").Delete
End With
End Sub

回答No.4

sakenomo

countif関数を使ったマクロでやってみました。
Sheet1のG列に検索値、Sheet2のB列（列の全部）を検索対象として、
マッチしたものをシート「ある」、しないものをシート「ない」にコピーします。
検索値に空白のセルがあると、Sheet2のB列の空白のセルに合致して、「ある」になりますのでご注意を。

Sub test()
Dim i As Long, p As Long, n As Long, c As Range
Worksheets.Add Before:=Sheets("Sheet1")
ActiveSheet.Name = "ある"
Worksheets.Add Before:=Sheets("Sheet1")
ActiveSheet.Name = "ない"
With Sheets("Sheet1")
.Select
Set c = .Range(Cells(1, 1), Cells(.Range("G65536").End(xlUp).Row, 9))
For i = 1 To c.Rows.Count
If Application.WorksheetFunction.CountIf(Sheets("Sheet2") _
.Columns("B"), .Range("G" & i)) = 0 Then
p = p + 1
Sheets("ない").Range(c.Address).Rows(p).Value = c.Rows(i).Value
Else
n = n + 1
Sheets("ある").Range(c.Address).Rows(n).Value = c.Rows(i).Value
End If
Next
End With
End Sub

回答No.3

imogasi

＃１です。シート２の項目（セル）をシート３に移すのなら
sh3.Cells(j, 1) = sh2.Cells(x.row, 1)
になると思います。

回答No.1

imogasi

>マクロをかじり始めて10日ですがよろしく
この段階ではごく例外の方（例えば他の言語でプロ級の方、回りに聞く人がいる人、若くて適性があり意欲に燃えた人など）を除いて、本質問をＶＢＡでやるのは無理でしょう。
なぜなら回答例が出ても、どこをどう変えたらよいか、
自力で判らない可能性があります。
まる写しせざるをえないでしょうから。
そうは思いますが、朝時間が無いので、ざっと作ってみました。穴だらけかもしれませんが、載せてみます。
Sub test01()
Dim sh1 As Worksheet　'シート１
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = Worksheets("sheet1") 'シート１
Set sh2 = Worksheets("sheet2")
Set sh3 = Worksheets("sheet3")
j = 1 'シート３の書きこみ用ポインタ
'-----シート１最下行を知る
d1 = sh1.Range("a1").CurrentRegion.Rows.Count
'-----シート１最下行までＡ列セルに付いて繰り返す
For i = 1 To d1
'-----シート１Ａ列第ｉ行の文字列（数字）セルに付いて
'--シート２のＡ列に見つかるか
Set x = sh2.Columns(1).Find(sh1.Cells(i, 1))
If x Is Nothing Then
Else
'--シート３のＡ列にシート１のＡ列データをセット
sh3.Cells(j, 1) = sh1.Cells(i, 1)
'--シート３のＡ列の次の行をセット
j = j + 1 '次行を指す
End If
Next i
End Sub
同じ数があると上記ではダメで、ＦｉｎｄＮｅｘｔ等を
使って複雑になります。
上記ではＡ列だけ移す例ですが、
シート１にＢ，Ｃ・・Ｉ列あるのでしたら
sh3.Cells(j, 2) = sh1.Cells(i, 2) 'Ｂ列
sh3.Cells(j, 3) = sh1.Cells(i, 3) 'Ｃ列
・・・
を付け加えてください。