比较五个Excel工作簿并将匹配的数据复制到一个新的工作簿

我试图在Excel中比较五个工作簿，并有匹配的列数据将整个行复制到一个新的工作簿（FinalReport）。 例如：如果有2到5个匹配的名称，则将整个行复制到新的工作簿（FinalReport）中。 所以如果在3个工作簿中匹配一个名称，报表页面将有3行用于该名称（每个工作簿一个）。另外，为了使每个名称数据行与其他名称分开，意味着如果在所有工作簿中有多于1个名称匹配，每个名称的数据批量将显示为一个单独的表格，报表页面上的表格应如下图所示： 单击此处最后一个Col（Copied From）是从其中find和复制匹配名称的页面名称。

这里是代码：

> `Sub CopyRowsIfNameAppears2ormoreTimes() > Application.ScreenUpdating = False > '1. The files names are "List1", "Arba_let2", "Expedia1", > "Expedia2", "Book3" '2. The folder path is: > Documents\HR_Books\BooksList > > 'assumes headers in row 1 of each workbook > 'assumes file extensions are .xlsx > > 'variables, path and file names > Dim wb As Workbook, wbNew As Workbook, wsNew As Worksheet, ws As Worksheet > Dim wbNamesArr, myPath As String, wbName As String, newFileName As String, c As String > Dim n As Integer, r As Long, i As Long > Dim rng As Range, copyRng As Range > wbNamesArr = Array("List1", "Arba_let2", "Expedia1", "Expedia2", "Book3") > myPath = "C:\GoldDR\Documents\HR_Books\BooksList" & "\" > If Right(myPath, 1) = "\" Then myPath = Left(myPath, Len(myPath) - 1) > 'create new file > newFileName = "FinalReport" & Format(Now, "hh mm ss") > Set wbNew = Workbooks.Add > wbNew.SaveAs (myPath & "\" & newFileName) > Set wsNew = wbNew.Worksheets(1) > > 'open each file in turn > For n = 0 To UBound(wbNamesArr) > wbName = myPath & "\" & wbNamesArr(n) & ".xlsx" > Set wb = Workbooks.Open(wbName) > Set ws = wb.Worksheets(1) > 'add header row to new file > If n = 0 Then ws.Rows("1:1").Copy Destination:=wsNew.Range("A1") > 'copy sheet values and paste to new file > r = ws.Range("A" & Cells.Rows.Count).End(xlUp).Row > Set copyRng = ws.Rows("2:" & r) > copyRng.Copy Destination:=wsNew.Range("A" & Cells.Rows.Count).End(xlUp).Offset(1) > wb.Close Next n > With wsNew > r = .Range("A" & Cells.Rows.Count).End(xlUp).Row 'insert temporary working columns > .Columns("A:B").Insert Shift:=xlToRight > > 'insert temporary formulas > For i = 2 To r > .Range("A" & i).Formula = "=COUNTIF(C2:C" & r & ",C" & i & ")" > .Range("B" & i).Value = i > Next i > > c = .Cells(1, wsNew.Cells.Columns.Count).End(xlToLeft).Address(0, 0) > Set rng = .Range("A1:" & c).Resize(r) > 'remove all rows where count of names is not equal to 2 or more > rng.AutoFilter Field:=1, Criteria1:="1", Operator:=xlFilterValues > rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete > rng.AutoFilter > 'sort by name > r = .Range("A" & Cells.Rows.Count).End(xlUp).Row > Set copyRng = wsNew.Rows("1:1") > Set rng = .Range("A1:" & c).Resize(r) > rng.Sort Key1:=.Range("C1"), Header:=xlYes > 'insert header for each "name" and a blank row in between each name block > For i = r To 2 Step -1 > If i = 2 Then Exit For > copyRng.Copy > If .Cells(i, 3) <> .Cells(i - 1, 3) Then > .Cells(i, 1).EntireRow.Insert Shift:=xlDown > Application.CutCopyMode = xlCopy > .Rows(i).Insert > End If > Next i > > 'delete temporary column > .Columns("A:B").Delete > 'add borders > r = .Range("A" & Cells.Rows.Count).End(xlUp).Row > c = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column > For r = 1 To r > If Not IsEmpty(.Cells(r, 1)) Then > Set rng = .Cells(r, 1).Resize(, c) > With rng.Borders(xlEdgeLeft) > .LineStyle = xlContinuous > .Weight = xlThin > End With > With rng.Borders(xlEdgeTop) > .LineStyle = xlContinuous > .Weight = xlThin > End With > With rng.Borders(xlEdgeBottom) > .LineStyle = xlContinuous > .Weight = xlThin > End With > With rng.Borders(xlEdgeRight) > .LineStyle = xlContinuous > .Weight = xlThin > End With > With rng.Borders(xlInsideVertical) > .LineStyle = xlContinuous > .Weight = xlThin > End With > With rng.Borders(xlInsideHorizontal) > .LineStyle = xlContinuous > .Weight = xlThin > End With > End If > Next r > End With Application.ScreenUpdating = True 'save the file > wbNew.Save > > End Sub 

但结果如下所示： 结果图像

任何帮助，将不胜感激。 谢谢