[[20230325201408]]　『VBA　重複値をカットして分けるマクロについて。』（みずき）　ページの最後に飛ぶ

『VBA　重複値をカットして分けるマクロについて。』（みずき）

ブックA（比較元）A列の値と重複するブックB（比較先）A列の値をチェックし、重複する値の行をカット→「重複値をカットした値のみ保存※１」と「重複値のみ新規ブックに保存※２」という結果にしたいのですが、※１及び２共に行ではなくセルのみ動いてしまいます。
これを、行ごと操作するにはどうしたら良いでしょうか？

Sub test()
Dim fileName1 As String
Dim fileName2 As String
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim lastRow As Long
Dim i As Long
Dim myObj As Range

fileName1 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "左ブックを指定してください。")
If fileName1 = "False" Then
Exit Sub
End If

fileName2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "右ブックを指定してください。")
If fileName2 = "False" Then
Exit Sub
End If

Set wb1 = Workbooks.Open(fileName1)
Set sheet1 = wb1.Sheets(1)

Set wb2 = Workbooks.Open(fileName2)
Set sheet2 = wb2.Sheets(1)

lastRow = sheet1.Cells(sheet1.Rows.Count, "A").End(xlUp).Row

Dim wb3 As Workbook
Dim sheet3 As Worksheet
Dim lastRow3 As Long
Set wb3 = Workbooks.Add
Set sheet3 = wb3.Sheets(1)
lastRow3 = 1

For i = 1 To lastRow
If sheet1.Cells(i, 1).Interior.Color = vbRed Then
Do
Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
If Not (myObj Is Nothing) Then

sheet3.Cells(lastRow3, 1) = myObj
lastRow3 = lastRow3 + 1

myObj.Delete Shift:=xlUp
End If
Loop While Not (myObj Is Nothing)
End If
Next i
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=True
MsgBox "完了しました。"
End Sub

※知恵袋で相談させて頂いたのですが、解決する前に早まって閉じてしまったため、こちらで教えを乞ってます。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

 ＞    lastRow3 = 1
 ＞
 ＞    For i = 1 To lastRow
 ＞        If sheet1.Cells(i, 1).Interior.Color = vbRed Then
 ＞            Do
 ＞                Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
 ＞                If Not (myObj Is Nothing) Then
 ＞                    sheet3.Cells(lastRow3, 1) = myObj
 ＞                    lastRow3 = lastRow3 + 1
 ＞                    myObj.Delete Shift:=xlUp
 ＞                End If

 こんなことじゃないかなぁ（テストしてないですが・・）
 　’↓
     lastRow3 = 1

     Dim shCols As Long
     shCols = sheet2.UsedRange.Columns.Count

     For i = 1 To lastRow
         If sheet1.Cells(i, 1).Interior.Color = vbRed Then
             Do
                 Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)

                     If Not (myObj Is Nothing) Then
                         sheet3.Cells(lastRow3, 1).Resize(1, shCols) = myObj.Resize(1, shCols).Value
                         lastRow3 = lastRow3 + 1
                         myObj.EntireRow.Delete Shift:=xlUp
                     End If

（半平太） 2023/03/25(土) 21:40:27

ありがとうございます！
ほぼ求めている動作なのですが、「重複値のみ新規ブックに保存」のみできませんでした。
マクロ実行中の最後に「book1」というエクセルが開いて閉じるのは表示されるのですが、デスクトップやドキュメント内を探してみましたが見当たりませんでした。
原因わかりますでしょうか？
（みずき） 2023/03/25(土) 23:14:01

すみません、ありました！
ありがとうございましたm(__)m
（みずき） 2023/03/25(土) 23:17:25

 そうですか・・・しかし、

 ＞                   lastRow3 = lastRow3 + 1
 ＞                   myObj.EntireRow.Delete Shift:=xlUp
 ＞                End If
 ＞            Loop While Not (myObj Is Nothing)

 myObjはDeleteしているのに、その後で、
 それをループ継続判定に利用しているのは、おかしいかも知れない。

 既に、myObjがNothingかどうか、上流で判定しているので、
 While条件は要らないと思う。Elseを挿入して抜けさせるべきでは？

                      lastRow3 = lastRow3 + 1
                      myObj.EntireRow.Delete Shift:=xlUp
                   Else
                       Exit Do　’←ここでDoループを抜けさせる。
                   End If
                 Loop

（半平太） 2023/03/25(土) 23:59:20

myObjはDeleteしているのに、その後で、それをループ継続判定に利用しているのは、おかしいかも知れない。既に、myObjがNothingかどうか、上流で判定しているので、 While条件は要らないと思う。Elseを挿入して抜けさせるべきでは？

なるほど。ご指摘ありがとうございます。
また、サンプルコードも添えて頂き、勉強になります！m(__)m
（みずき） 2023/03/26(日) 13:34:40

既に解決しているようなので別に良いのでしょうが、少し気になる点をいくつか。

■１
[[20230325202304]]でも指摘されている話ですが、こだわりがなければインデントを付けたほうがよいです。
適切なインデントを付けることにより、コードの構造が把握しやすくなりご自身のデバッグ作業の効率アップに寄与すると思います。

    Sub test()
        Dim fileName1 As String, fileName2 As String
        Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
        Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
        Dim lastRow As Long, i As Long, lastRow3 As Long
        Dim myObj As Range

        fileName1 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "左ブックを指定してください。")
        If fileName1 = "False" Then
            Exit Sub
        End If

        fileName2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "右ブックを指定してください。")
        If fileName2 = "False" Then
            Exit Sub
        End If

        Set wb1 = Workbooks.Open(fileName1)
        Set sheet1 = wb1.Sheets(1)
        lastRow = sheet1.Cells(sheet1.Rows.Count, "A").End(xlUp).Row

        Set wb2 = Workbooks.Open(fileName2)
        Set sheet2 = wb2.Sheets(1)

        Set wb3 = Workbooks.Add
        Set sheet3 = wb3.Sheets(1)
        lastRow3 = 1

        For i = 1 To lastRow
            If sheet1.Cells(i, 1).Interior.Color = vbRed Then
                Do
                    Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
                    If Not (myObj Is Nothing) Then
                        sheet3.Cells(lastRow3, 1) = myObj
                        lastRow3 = lastRow3 + 1
                        myObj.Delete Shift:=xlUp
                    End If
                Loop While Not (myObj Is Nothing)
            End If
        Next i

        wb1.Close SaveChanges:=False
        wb2.Close SaveChanges:=True
        MsgBox "完了しました。"
    End Sub

■２
エラーにはならないようですが↓は違和感を感じます。（返り値を求める必要がないから、括弧はいらないとおもいます。）

 If Not (myObj Is Nothing) Then
 Loop While Not (myObj Is Nothing)

■３
半平太さんからアドバイスがあるところですが、↓のようにする方法もあると思います。

        For i = 1 To lastRow
            If sheet1.Cells(i, 1).Interior.Color = vbRed Then
                Do
                    Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
                    If Not (myObj Is Nothing) Then
                        sheet3.Cells(lastRow3, 1) = myObj
                        lastRow3 = lastRow3 + 1
                        myObj.Delete Shift:=xlUp
                    End If
                Loop While Not (myObj Is Nothing)
            End If
        Next i
                       ↓処理前に「myObj」が「Nothing」でないか判定する

        For i = 1 To lastRow
            If sheet1.Cells(i, 1).Interior.Color = vbRed Then
                Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
                Do Until myObj Is Nothing
                    sheet3.Cells(lastRow3, 1) = myObj
                    lastRow3 = lastRow3 + 1
                    myObj.Delete Shift:=xlUp
                    Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
                Loop While Not (myObj Is Nothing)
        Next i

■４
＞ブックA（比較元）A列の値と重複するブックB（比較先）A列の値をチェックし～
値があるかどうかだけであればFindメソッドで探さなくても、作業列にCOUNTIF関数を使った数式を書き込むことでも確認できます。

    Sub 実験()
        Dim buf As String
        buf = Workbooks("ブックB").Worksheets(1).Range("A:A").Address(External:=True)

        With Workbooks("ブックA").Worksheets(1)
            .Range("B2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Formula = _
            "=COUNTIF(" & buf & ",A2)"
        End With
    End Sub

項目列がある（用意できる）ことが前提ですが、「重複値」がブックB（比較先）にもあるものという意味であれば、

 1.　オートフィルタを設定する

 2.　作業列が【1以上】のものを抽出する

 3.　最終行を調べたときに２以上であれば
         新規ブックを用意して抽出されているものをコピペする
         項目行を除き抽出されている行を削除する

 4.　作業列を削除して、ブックA（比較元）を上書き？保存する。

というアプローチも可能だと思います。
データ量にもよりますが、１行ずつ処理するより早くなることもあるとおもいますから興味があれば検討してみてください。

（もこな２） 2023/03/26(日) 14:23:34

丁寧な解説とご提案、ありがとうございます。

最終的に以下のようにしたのですが、現在はセルが対象で「比較先の重複値をカット→＆新規ブックにペースト」ですが、これを行ごとカット＆ペーストするにはどうしたら良いでしょうか？
InStrを使ってみたのですがうまくいきませんでした。

 Sub test()
        Dim fileName1 As String, fileName2 As String
        Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
        Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
        Dim lastRow As Long, i As Long, lastRow3 As Long
        Dim myObj As Range
        fileName1 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "左ブックを指定してください。")
        If fileName1 = "False" Then
            Exit Sub
        End If
        fileName2 = Application.GetOpenFilename("Microsoft Excelブック,*.xls*", , "右ブックを指定してください。")
        If fileName2 = "False" Then
            Exit Sub
        End If
        Set wb1 = Workbooks.Open(fileName1)
        Set sheet1 = wb1.Sheets(1)
        lastRow = sheet1.Cells(sheet1.Rows.Count, "A").End(xlUp).Row
        Set wb2 = Workbooks.Open(fileName2)
        Set sheet2 = wb2.Sheets(1)
        Set wb3 = Workbooks.Add
        Set sheet3 = wb3.Sheets(1)
        lastRow3 = 1
        For i = 1 To lastRow
            If sheet1.Cells(i, 1).Interior.Color = vbRed Then
                Do
                    Set myObj = sheet2.Range("A:A").Find(sheet1.Cells(i, 1), LookAt:=xlWhole)
                    If Not myObj Is Nothing Then
                        sheet3.Cells(lastRow3, 1) = myObj
                        lastRow3 = lastRow3 + 1
                        myObj.Delete Shift:=xlUp
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next i
        wb1.Close SaveChanges:=False
        wb2.Close SaveChanges:=True
        MsgBox "完了しました。"
    End Sub
（みずき） 2023/04/07(金) 16:19:46

■５
確認ですが、「■４」を検討した上での追加質問なんですよね？

■６
＞現在は～「比較先の重複値をカット→＆新規ブック」
そのような処理になっていません。

 1. [myObj]という変数にFindメソッドでみつけた【セル】を格納する
 2. [sheet3.Cells(lastRow3, 1)]の値として、[myObj]に格納した【セル】の値を書き込む
 3. [myObj]に格納した【セル】を削除する

ということをしています。きちんと確認してみてください。
よって、仰るとおり↓のようにカット＆ペーストにすれば希望の動作になるのでは？

 1. [myObj]という変数にFindメソッドでみつけた【セル】を格納する
 2. [myObj]に格納した【セル】【を含む行】をカットする
 3. [sheet3.Cells(lastRow3, 1)]にペーストする

（もこな２） 2023/04/07(金) 19:41:58

コメント返信：

[ 一覧(最新更新順) ]

[[20230325201408]] 『VBA 重複値をカットして分けるマクロについて。』（みずき） ページの最後に飛ぶ

[[20230325201408]]　『VBA　重複値をカットして分けるマクロについて。』（みずき）　ページの最後に飛ぶ