VBA Excel copy rows based on column

问题

I'm trying to create a macro which copies rows of data after comparing a column value. I previously asked this question but made some progress, and thought it would be less confusing if i posted another question. The column to be compared is "eRequest ID" and it consists of integers and text.

I have two worksheets, both with "eRequest ID" as the first column. The goal here is to copy ANY rows of data that has an "eRequest ID" NOT FOUND in both worksheets. Meaning if this record's "eRequest ID" is only found on one worksheet and not both, the whole row of data has to be copied into a third new worksheet.

I have worked out some codes after browsing through the net, and with the help of the coding experts here. The problem with this codes is that somehow I get a "mismatch" for every row. I tried changing the foundTrue value here and there but it doesn't seem to work. I need it to only copy rows of data with only 1 "eRequest ID" on either worksheet. Greatful for any help and appreciate your effort!

Sub compareAndCopy()

Dim lastRowE As Integer
Dim lastRowF As Integer 
Dim lastRowM As Integer
Dim foundTrue As Boolean

Application.ScreenUpdating = False

lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Sheets("JULY15Release_Master Inventory").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Sheets("JULY15Release_Dev status").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "A").End(xlUp).Row

For i = 1 To lastRowE
foundTrue = True
For j = 1 To lastRowF

'If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value = Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
 If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value <> Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
    foundTrue = False
    Exit For
End If

Next j

If foundTrue Then
Sheets("JULY15Release_Dev status").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1

End If


Next i

Application.ScreenUpdating = False

End Sub

回答1:

another one variant

    Sub test()
    Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
    Dim Cle As Range, Clf As Range
    Dim DicInv As Object: Set DicInv = CreateObject("Scripting.Dictionary")
    Dim DicDev As Object: Set DicDev = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = 0

    lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
    lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
    lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row

    'add into dictionary row number from Inventory where cell is matched
    For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
        If Cle.Value <> "" Then
            For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
                If UCase(Cle.Value) = UCase(Clf.Value) Then DicInv.Add Cle.Row, ""
            Next Clf
        End If
    Next Cle
    'add into dictionary row number from Dev where cell is matched
    For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
        If Clf.Value <> "" Then
            For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
                If UCase(Clf.Value) = UCase(Cle.Value) Then DicDev.Add Clf.Row, ""
            Next Cle
        End If
    Next Clf
    'Get mismatch from Inventory
    With Sheets("JULY15Release_Master Inventory")
        For Each Cle In .Range("A1:A" & lastRowE)
            If Not DicInv.exists(Cle.Row) And Cle.Value <> "" Then
                .Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
                lastRowM = lastRowM + 1
            End If
        Next Cle
    End With
    'Get mismatch from Dev
    With Sheets("JULY15Release_Dev status")
        For Each Clf In .Range("A1:A" & lastRowF)
            If Not DicDev.exists(Clf.Row) And Clf.Value <> "" Then
                .Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
                lastRowM = lastRowM + 1
            End If
        Next Clf
    End With

    Application.ScreenUpdating = 1

    End Sub

Sample

JULY15Release_Master Inventory

JULY15Release_Dev status

Output Result

Mismatch

回答2:

Try this, it should work, TESTED.

Sub test()

Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long
Dim K As Long
Dim j As Long
Dim p As Variant
Dim wb As Workbook

Set wb = ThisWorkbook
K = 2
lrow1 = wb.Sheets("JULY15Release_Master Inventory").Range("A" & Rows.Count).End(xlUp).Row
lrow2 = wb.Sheets("JULY15Release_Dev status").Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lrow1

p = Application.Match(wb.Sheets("JULY15Release_Master Inventory").Range("A" & i).Value, wb.Sheets("JULY15Release_Dev status").Range("A1" & ":" & "A" & lrow2), 0)
If IsError(p) Then
        wb.Sheets("JULY15Release_Master Inventory").Rows(i).Copy Destination:=Sheets("Mismatch").Rows(K)
        K = K + 1
End If
Next

For j = 1 To lrow2
p = Application.Match(wb.Sheets("JULY15Release_Dev status").Range("A" & j).Value, wb.Sheets("JULY15Release_Master Inventory").Range("A1" & ":" & "A" & lrow1), 0)
If IsError(p) Then
        wb.Sheets("JULY15Release_Dev status").Rows(j).Copy Destination:=Sheets("Mismatch").Rows(K)
        K = K + 1
End If
Next
End Sub

来源：https://stackoverflow.com/questions/30066702/vba-excel-copy-rows-based-on-column