Help To Compare five Excel workbooks and copying matched data to a new workbook

[net1media]

I'm trying to compare five workbooks to each other in excel and have matching column data copy the entire rows into a new workbook (FinalReport). eg: If there are 2 to 5 names matched, copy the entire rows to the new Workbook (FinalReport). so if a name matched in 3 workbooks, the report page will have 3 rows for that name (one from each workbook). Also to make each name data rows separated from others, meaning if there are more than 1 name matched in all of the workbooks, each name data bulk to appear as a separate table, The table on the report page should look like the following image:

19709

Here is the code:


Sub CopyRowsIfNameAppears2ormoreTimes()Application.ScreenUpdating = False
'1. The files names are "List_1", "Arba_let2", "Expedia1", "Expedia2", "Book3"
'2. The folder path is: Documents\HR_Books\BookList

'assumes data in 1st sheet 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("List_1", "Arba_let2", "Expedia1", "Expedia2", "Book3")
myPath = "C:\GoldStar\Documents\HR_Books\BookList" & "\"
If Right(myPath, 1) = "\" Then myPath = Left(myPath, Len(myPath) - 1)

'create new file
newFileName = "FinalReport" & Format(Now, "hh mm ss") 'amend to suit
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

End With
Application.ScreenUpdating = True
'save the file
wbNew.Save


End Sub




But the result looks like the following:
19705


19706

Any help would be appreciated.
Thanks