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行并将其粘贴到“Mix”表单中
答案 0 :(得分：1)
我发现像三列匹配这样的最有效的方法通常是一个Scripting.Dictionary对象，它带有自己唯一的引用键索引。临时＆＃39;帮手＆＃39;连接单个比较的三个值的列是另一个选项，但是“内存中”＆＃39;评估通常是最有效的。
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
我在传输中使用了原始值。您很可能必须在混合工作表中正确格式化日期值等内容，但对于编程爱好者来说这不应该是一个问题。
答案 1 :(得分：0)
请尝试以下代码
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