匹配两个工作表上的三列，并将两个工作表上的行复制到一个新工作表中

Dim rOriginal As Range          'row records in the lookup sheet (cList = Sheet2)
Dim rFind As Range              'row record in the target sheet (TotalList = Sheet1)
Dim rTableOriginal As Range     'row records in the lookup sheet (cList = Sheet2)
Dim rTableFind As Range         'row record in the target sheet (TotalList = Sheet1)
Dim shOriginal As Worksheet
Dim shFind As Worksheet
Dim booFound As Boolean
Dim shMix As Worksheet

'Initiate all used objects and variables
Set shOriginal = ThisWorkbook.Sheets("Male")
Set shFind = ThisWorkbook.Sheets("Female")
Set shMix = ThisWorkbook.Sheets("Mix")
Set rTableOriginal = shOriginal.Range(shOriginal.Rows(2), shOriginal.Rows(shOriginal.Rows.count).End(xlUp))
Set rTableFind = shFind.Range(shFind.Rows(2), shFind.Rows(shFind.Rows.count).End(xlUp))
booFound = False

      For Each rOriginal In rTableOriginal.Rows
       booFound = False
         For Each rFind In rTableFind.Rows
           'Check if the E and F column contain the same information
               If rOriginal.Cells(1, 1) = rFind.Cells(1, 1) And rOriginal.Cells(1, 13) = rFind.Cells(1, 13) And rOriginal.Cells(1, 11) = rFind.Cells(1, 11) Then
                 'The record is found so we can search for the next one
                    booFound = True
                    GoTo FindNextOriginal 'Alternatively use Exit For
               End If
         Next rFind

            'In case the code is extended I always use a boolean and an If statement to make sure we cannot
            'by accident end up in this copy-paste-apply_yellow part!!
            If booFound = True Then
                'If not found then copy form the Original sheet ...
                rOriginal.Copy
                rFind.Copy
                '... paste on the Find sheet and apply the Yellow interior color
                With shMix.Rows(Mix.Rows.count + 1)
                    .PasteSpecial

                End With

            End If

FindNextOriginal:
        Next rOriginal

So I have searched the site and came up with the codes above. But it still doesn't seem to work. My objective is to match 3 columns on sheet "Male" with another 3 columns on sheet "Female" if it matches, the code will then copy the row on both sheets and paste it on sheet "Mix". The columns I am trying to compare are columns A , K and M respectively.

所以我搜索了网站，找到了上面的代码。但它似乎仍然不起作用。我的目标是将“Male”表上的3列与“Female”表上的3列匹配，如果匹配，则代码将复制两个表上的行并将其粘贴到“Mix”表上。我要比较的列分别是A、K和M。

Example:

例子:

Column A | Column K | Column M
1/1/2000 | 20       | 1 
2/1/2000 | 21       | 4 
3/1/2000 | 22       | 5 

1/1/2000 | 20       | 1 
4/1/2000 | 24       | 3 
6/1/2000 | 25       | 6 

Copy row 1 on both worksheet and paste it in sheet "Mix"

将第1行复制到工作表上，并将其粘贴到工作表“Mix”中

2 个解决方案

#1

I've found that the most efficient method for something like a three column match is often a Scripting.Dictionary object that comes with its own unique reference key index. Temporary 'helper' columns that concatenate the three values for a single comparison are another option but 'in-memory' evaluation is usually the most efficient.

我发现，对于三列匹配之类的东西，最有效的方法通常是脚本。Dictionary对象，该对象具有自己的惟一引用键索引。将三个值连接到一个比较的临时“帮助”列是另一个选项，但“内存中”评估通常是最有效的。

Sub three_col_match_and_copy()
    Dim c As Long, v As Long, w As Long, vTMPs As Variant, itm As String, vVALs() As Variant, k As Variant
    Dim dTMPs As Object '<~~ late binding use As New Scipting.Dictionary for early binding
    Dim dMIXs As Object '<~~ late binding use As New Scipting.Dictionary for early binding

    'late binding of the dictionary object
    Set dTMPs = CreateObject("Scripting.Dictionary")
    Set dMIXs = CreateObject("Scripting.Dictionary")

    'grab all of Males into variant array
    With Worksheets("male")
        With .Cells(1, 1).CurrentRegion
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                vTMPs = .Cells.Value2
            End With
        End With
    End With

    'build first dictionary
    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
        If Not dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
            itm = "gonna be discarded in any event"
            dTMPs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
                      Item:=itm
        End If
    Next v

    'grab all of Females into reused variant array
    With Worksheets("female")
        With .Cells(1, 1).CurrentRegion
            With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
                vTMPs = .Cells.Value2
            End With
        End With
    End With

    'save for later
    c = UBound(vTMPs, 2)

    'build second dictionary on matches
    For v = LBound(vTMPs, 1) To UBound(vTMPs, 1)
        If dTMPs.exists(Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203))) Then
            itm = vTMPs(v, 1)
            For w = LBound(vTMPs, 2) + 1 To UBound(vTMPs, 2)
                itm = Join(Array(itm, vTMPs(v, w)), ChrW(8203))
            Next w
            dMIXs.Add Key:=Join(Array(vTMPs(v, 1), vTMPs(v, 11), vTMPs(v, 13)), ChrW(8203)), _
                      Item:=itm
        End If
    Next v

    'continue if there is something to xfer
    If CBool(dMIXs.Count) Then
        'create variant array of the matches from the dictionary
        v = 1
        ReDim vVALs(1 To dMIXs.Count, 1 To UBound(vTMPs, 2))
        Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1)
        Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2)
        For Each k In dMIXs
            vTMPs = Split(dMIXs.Item(k), ChrW(8203))
            For w = LBound(vTMPs) To UBound(vTMPs)
                vVALs(v, w + 1) = vTMPs(w)
            Next w
            v = v + 1
            Debug.Print dMIXs.Item(k)
        Next k

        'put the matched rows into the Mix worksheet
        With Worksheets("mix")
            With .Cells(1, 1).CurrentRegion
                With .Resize(UBound(vVALs, 1), UBound(vVALs, 2)).Offset(1, 0)
                    .Cells = vVALs
                End With
            End With
        End With
    End If


    dTMPs.RemoveAll: Set dTMPs = Nothing
    dMIXs.RemoveAll: Set dMIXs = Nothing

End Sub

I have used raw values in the transfer. You will most likely have to correctly format things like date values in the Mix worksheet but that should not be a problem for a 'programming enthusiast'.

我在传输中使用了原始值。你很可能必须在混合工作表中正确地格式化日期值之类的东西，但这对“编程爱好者”来说应该不是问题。

#2

Kindly try the following code

请尝试以下代码。

 Sub Test()

Dim lastr As Long
Dim lastrmale As Long
Dim lastrfemale As Long
Dim lastrmix As Long
Dim malesheet As Worksheet
Dim Femalesheet As Worksheet
Dim mixsheet As Worksheet
Dim i As Long
Set malesheet = Worksheets("Male")
Set Femalesheet = Worksheets("Female")
Set mixsheet = Worksheets("mix")
lastrmale = malesheet.Range("A" & malesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row

lastrfemale = Femalesheet.Range("A" & Femalesheet.Range("A1").SpecialCells(xlLastCell).Row + 1).End(xlUp).Row

lastr = WorksheetFunction.Min(lastrmale, lastrfemale)
lastrmix = 2
For i = 2 To lastr

    If (malesheet.Range("A" & i).Value = Femalesheet.Range("A" & i).Value) And (malesheet.Range("K" & i).Value = Femalesheet.Range("K" & i).Value) And (malesheet.Range("M" & i).Value = Femalesheet.Range("M" & i).Value) Then

        malesheet.Rows(i & ":" & i).Copy
        mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
    lastrmix = lastrmix + 1
    Femalesheet.Rows(i & ":" & i).Copy
        mixsheet.Range("A" & lastrmix).PasteSpecial xlPasteAll
    lastrmix = lastrmix + 1

    End If
Next
End Sub