我试图在excel中将五个工作簿相互比较，并将匹配的列数据复制到一个新的工作簿（FinalReport）中。例如：如果匹配2到5个名称，则将整行复制到新工作簿（FinalReport）。因此，如果名称在3个工作簿中匹配，则报表页面将有3行用于该名称（每个工作簿中有一行）还要使每个名称数据行与其他名称分开，这意味着在所有工作簿中匹配的名称多于1个，每个名称数据批量显示为单独的表，报表页面上的表应如下图所示： Click here 最后一个Col（Copied From）是找到并复制匹配名称的页面名称。
以下是代码：
> `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
但结果如下： Result image
任何帮助将不胜感激。 感谢
