將兩張工作表上的三列與兩張紙上的行相匹配複製到一張新紙上

Question

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 

因此，我已經搜索了該網站並提出了上述代碼。但它似乎仍然不起作用。我的目標是匹配「男性」表格上的3列與表格「女性」上的另外3列，如果匹配，代碼將複製兩張表格上的行並將其粘貼到「混合」表格上。我試圖比較的列分別是A，K和M列。舉例

：

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 

複製第1行兩個工作表並粘貼到表 「驢友」

Answer 1

請嘗試以下代碼

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 

Answer 2

我發現，最像三列匹配這樣的高效方法通常是一個Scripting.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 

我在轉移中使用了原始值。您很可能必須在Mix工作表中正確格式化日期值等內容，但這對於「編程愛好者」不應該是個問題。