将2张数据以交错格式复制到一张纸上
我有两组数据在每张表中有两列相同的列。 我想从两张表中复制两组数据到第三张，但是采用以下格式： –
Sheet1 Name Age Gender Mayur 23 M Alex 24 M Maria 25 F April 19 F Sheet2 Name Age Gender Mayur 21 M Maria 24 F Alex 24 M June 20 F Sheet3 Name1 Name2 Age1 Age2 Gender1 Gender2 Mayur Mayur 23 21 MM Alex Alex 24 24 MM Maria Maria 25 24 FF April 19 F June 20 F 现在有一个主要的列，即名称。 这个列永远不会是空的。 这两张纸可能没有相同顺序的数据。 这两张表可能有不同的条目为相同的名称。 任何一张纸上都可能有一个名字不见了
我已经写了下面的代码：
我从sheet1中的sheet1中find名称，然后将这个名称的相应条目从这两个表复制到sheet3。
如果在工作表2中没有find名字，那么它的数据就像上面所显示的一样被复制。最后，如果在工作表1中没有任何名字，则在工作表1中search名称，然后在工作表3中复制这些条目。
现在search部分运行得很好，但复制部分需要很多时间。
我已经尝试了复制数据的其他方法，但没有一个运行得很快。 在实际数据中有200多列和数百万行。 整个过程运行超过6-7小时。
任何人都可以让我知道任何其他更快的方式来实现这一点。 即使这样可以把时间从7小时缩短到1小时或2小时，仍然很好。
另外，我需要突出显示我正在做的这种情况，即在从两张纸上复印时，如果数据不匹配，请更改单元格颜色。
下面是代码
Sub findUsingArray() Dim i As Long Dim j As Variant Dim noOfColumnsA As Integer Dim maxNoOfColumns As Integer Dim noOfRowsA As Long Dim noOfRowsB As Long Dim arrayColumnA() As Variant Dim arrayColumnB() As Variant Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim primaryKeyColumn As Integer Dim result As Long Set sheet1 = ThisWorkbook.Sheets("Sheet1") Set sheet2 = ThisWorkbook.Sheets("Sheet2") noOfColumnsA = sheet1.Cells(1, Columns.Count).End(xlToLeft).Column maxNoOfColumns = noOfColumnsA * 2 noOfRowsA = sheet1.Cells(Rows.Count, 1).End(xlUp).Row noOfRowsB = sheet2.Cells(Rows.Count, 1).End(xlUp).Row 'createHeader maxNoOfColumns Used to create header in 3rd sheet primaryKeyColumn = 1 ReDim arrayColumnA(noOfRowsA) ReDim arrayColumnB(noOfRowsB) arrayColumnA = sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)) arrayColumnB = sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)) result = 2 For i = 2 To noOfRowsA j = Application.Match(arrayColumnA(i, 1), sheet2.Range(sheet2.Cells(1, primaryKeyColumn), sheet2.Cells(noOfRowsB, primaryKeyColumn)), 0) If Not IsError(j) Then result = copyInaRowUsingArray(i, result, j, maxNoOfColumns) Else result = copyMissingRow(1, i, result, maxNoOfColumns) End If Next i For i = 2 To noOfRowsB j = Application.Match(arrayColumnB(i, 1), sheet1.Range(sheet1.Cells(1, primaryKeyColumn), sheet1.Cells(noOfRowsA, primaryKeyColumn)), 0) If IsError(j) Then result = copyMissingRow(2, i, result, maxNoOfColumns) End If Next i End Sub Function copyInaRowUsingArray(sheet1Index As Long, newRowIndex As Long, sheet2index As Variant, noOfColumns As Integer) Dim i As Long Dim j As Long Dim val As Variant Dim valueA As String Dim valueB As String Dim arrayA() As Variant Dim arrayB() As Variant Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim sheet3 As Worksheet Dim rowColoured As Boolean j = 1 Set sheet1 = ThisWorkbook.Sheets("Sheet1") Set sheet2 = ThisWorkbook.Sheets("Sheet2") Set sheet3 = ThisWorkbook.Sheets("Sheet3") arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheet1Index, 1), sheet1.Cells(sheet1Index, noOfColumns)).Value)) arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheet2index, 1), sheet2.Cells(sheet2index, noOfColumns)).Value)) rowColoured = False With sheet3 For i = 1 To noOfColumns valueA = arrayA(j) If Not valueA = "" Then .Cells(newRowIndex, i).Value = valueA End If i = i + 1 valueB = arrayB(j) If Not valueB = "" Then .Cells(newRowIndex, i).Value = valueB End If If Not StrComp(CStr(valueA), CStr(valueB)) = 0 Then If Not rowColoured Then .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 35 rowColoured = True End If .Cells(newRowIndex, i).Interior.ColorIndex = 34 .Cells(newRowIndex, i - 1).Interior.ColorIndex = 34 End If j = j + 1 Next i copyInaRowUsingArray = newRowIndex + 1 End With End Function Function copyMissingRow(sheetNo As Integer, sheetIndex As Long, newRowIndex As Long, noOfColumns As Integer) Dim i As Long Dim j As Long Dim val As Variant Dim valueA As String Dim valueB As String Dim arrayA() As Variant Dim arrayB() As Variant Dim sheet1 As Worksheet Dim sheet2 As Worksheet Dim sheet3 As Worksheet j = 1 Set sheet3 = ThisWorkbook.Sheets("Sheet3") With sheet3 If sheetNo = 1 Then Set sheet1 = ThisWorkbook.Sheets("Sheet1") ReDim arrayA(noOfColumns) arrayA = Application.Transpose(Application.Transpose(sheet1.Range(sheet1.Cells(sheetIndex, 1), sheet1.Cells(sheetIndex, noOfColumns)).Value)) For i = 1 To noOfColumns valueA = arrayA(j) If Not valueA = "" Then .Cells(newRowIndex, i).Value = valueA End If i = i + 1 j = j + 1 Next i .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 46 Else Set sheet2 = ThisWorkbook.Sheets("Sheet2") ReDim arrayB(noOfColumns) arrayB = Application.Transpose(Application.Transpose(sheet2.Range(sheet2.Cells(sheetIndex, 1), sheet2.Cells(sheetIndex, noOfColumns)).Value)) For i = 1 To noOfColumns i = i + 1 valueB = arrayB(j) If Not valueB = "" Then .Cells(newRowIndex, i).Value = valueB End If j = j + 1 Next i .Range(.Cells(newRowIndex, 1), .Cells(newRowIndex, noOfColumns)).Interior.ColorIndex = 3 End If copyMissingRow = newRowIndex + 1 End With End Function
按照其中一个评论，字典应该帮助你做什么。 此处使用的字典从表（2）中保存名称作为键和相应的行作为值。
Option Explicit Sub CopyRng(frmSht As Worksheet, frmRow As Integer, offset As Integer, toRow As Integer) Dim r As Integer For r = 1 To 3: Sheets(3).Cells(toRow, offset + 2 * r).Value = frmSht.Cells(frmRow, r).Value Next End Sub Sub InterleaveRows() Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") With Sheets(2) Dim r As Integer, r2 As Integer, r3 As Integer: r3 = 2 Dim val As String For r = 2 To .Range("A" & .Rows.Count).End(xlUp).row: dict(.Cells(r, "A").Value) = r Next End With CopyRng Sheets(1), 1, -1, 1 CopyRng Sheets(2), 1, 0, 1 For r = 2 To Sheets(1).Range("A" & Sheets(1).Rows.Count).End(xlUp).row: val = Sheets(1).Cells(r, "A").Value If (dict.Exists(val)) Then r2 = dict(val) CopyRng Sheets(1), r, -1, r3 CopyRng Sheets(2), r2, 0, r3 dict.Remove val Else CopyRng Sheets(1), r, -1, r3 End If r3 = r3 + 1 Next For r = 0 To dict.Count - 1 r2 = dict.items()(r) CopyRng Sheets(2), r2, 0, r3 r3 = r3 + 1 Next End Sub
“InterLeaveRows”子程序的第一个循环通过检查Sheet（2）中的所有条目来填充字典。 接下来的两行将表头写出（3）。 然后第二个循环将所有的值写入字典（即在Sheet（1）和Sheet（2）中）或Sheet（1）中的Sheet（3）; 注意这样做，从字典中写入到工作表（3）的条目将从字典中删除。 最后一个循环写出保留在字典中的键/ val对。 这些是仅在表（2）中的条目。