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:

Result.jpg

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:
Result2.jpg


Result3.jpg

Any help would be appreciated.
Thanks