在两张工作表中匹配三列,并将两张纸上的行像行一样复制到一张新纸上

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 

所以我search了这个网站,并提出了上面的代码。 但它似乎仍然没有工作。 我的目标是在表格“男性”上匹配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行,并将其粘贴到“混合”

我发现像三列匹配这样的最有效的方法通常是一个Scripting.Dictionary对象,它带有唯一的引用键索引。 为单个比较连接三个值的临时“帮手”列是另一种select,但是“内存中”评估通常是最有效的。

 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工作表中正确地设置date值的格式,但这对于“编程爱好者”不应该是一个问题。

请尝试下面的代码

  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