VBAの比較削除マクロ

質問

Sheet1とSheet2のB列を参照して同じ値が存在する場合は、Sheet1の行を削除するマクロを作成したいのですがどのように記述したらよいか分かりません。
Sheet1とSheet2のB列を参照して同じ値が存在する場合は、Sheet3にSheet1の行をコピーするマクロはホームページ等を参照して下記のように記述できました。

Public Sub copy()

Dim tempRange As Range
Dim fax1Table As Range
Dim fax2Table As Range
Dim dst As Range
Dim FoundCell As Range

'fax1範囲指定
Worksheets("Fax1").Activate
Set fax1Table = Range("a1").CurrentRegion
Set fax1Table = fax1Table.Offset(1)
Set fax1Table = fax1Table.Resize(fax1Table.Rows.Count - 1)

'fax2範囲指定
Worksheets("Fax2").Activate
Set fax2Table = Range("a1").CurrentRegion
Set fax2Table = fax2Table.Offset(1)
Set fax2Table = fax2Table.Resize(fax2Table.Rows.Count - 1)

'比較開始
Worksheets("fax1").Activate

'見出しコピー
Set dst = Worksheets("fax3").Range("a1")
Range("a1:ad1").copy dst

'レコード抽出
For Each tempRange In fax1Table.Rows
Set FoundCell = fax2Table.Columns(2).Find(tempRange.Columns(2).Value, , xlValues, xlWhole)
If Not FoundCell Is Nothing Then
Set dst = dst.Offset(1)
tempRange.copy dst
End If
Next tempRange

'比較終了

'セル幅自動調整
Worksheets("fax3").Range("a:g").Columns.AutoFit
Worksheets("fax3").Activate

End Sub

回答No.1

tom04 · ベストアンサー

こんばんは！
コードを詳しく見させてもらっていませんが・・・

＞Sheet1とSheet2のB列を参照して同じ値が存在する場合は、Sheet1の行を削除するマクロを作成したい
という要望だけの方法の一例です。
両Sheetとも1行目はタイトル行で2行目以降にデータがあるとします。

Sub test()
Dim i As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1") '←Sheet名は適宜変更してください。
Set ws2 = Worksheets("sheet2") '←こちらのSheet名も適宜変更
For i = ws1.Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(ws2.Range("B:B"), ws1.Cells(i, 2)) Then
ws1.Rows(i).Delete (xlUp)
End If
Next i
End Sub

上記のコードを標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

参考になれば良いのですが
外していたらごめんなさいね。m(__)m

お礼

回答ありがとうございました。
上記のコードを標準モジュールにコピー＆ペーストしてマクロを実行することができました。

回答No.3

merlionXX

一例です。

Sub test01()
　　Dim myW, myW2, myV
　　Dim buf As Boolean
　　Dim i As Long, j As Long, n As Long, m As Long, x As Long, y As Long, z As Long
　　With Sheets("Sheet1")
　　　　myW = .Range("A1", .UsedRange.Cells(.UsedRange.Count)).Value
　　End With
　　With Sheets("Sheet2")
　　　　myV = .Range("B1", .Cells(Rows.Count, "B").End(xlUp)).Value
　　End With
　　x = UBound(myW, 1)
　　y = UBound(myW, 2)
　　z = UBound(myV, 1)
　　ReDim myW2(1 To x, 1 To y)
　　For i = 1 To x
　　　　For n = 1 To z
　　　　　　If myW(i, 2) = myV(n, 1) Then
　　　　　　　　buf = True
　　　　　　　　Exit For
　　　　　　End If
　　　　Next n
　　　　If buf Then
　　　　　　buf = False
　　　　Else
　　　　　　j = j + 1
　　　　　　For m = 1 To y
　　　　　　　　myW2(j, m) = myW(i, m)
　　　　　　Next m
　　　　End If
　　Next i
　　With Sheets("Sheet1")
　　　　.Cells.ClearContents
　　　　.Range("A1").Resize(x, y).Value = myW2
　　End With
End Sub

お礼

回答ありがとうございました。
上記のコードを標準モジュールにコピー＆ペーストしてマクロを実行することができました。

回答No.2

koara1982

すいません。ブランクが長いのでコードは分かりません。

sheet1のB列の最終行から検索をかけて削除する必要があります。そのためにEnd(xlUp)で最終行を取得します。その次に変数をもうけ、for 変数 =　最終行 to 1 step -1 で下からどんどん検索します。
forの中にif をもうけて if worksheets(変数1).cells(,B) = worksheets(2).cells(変数,B) then worksheets(1).rows(変数).delete end if
をすればよいのではないでしょうか？

ってそんな簡単にはいかないですかね？

お礼

回答ありがとうございました