Importing a specific range of cells from multiple workbooks to a single workbook

Hello,

At the beginning I want to thank you all, who share their knowledge and help in all these threads. Many times I found here answers on my problems. But now, I need to face with hard thing to do in excel. I believe to find here some good advises how to do it.

Import specific information (specific range of cells) from only one worksheet (always it is sheet1, but called "Person") from differently named workbooks and put this information in specific range in active worksheet "Summary" in workbook "Data.xls". In table as you can see first line, paste manually.
As you can see, in file Data.xls there is a macro. I am completely beginner in VBA and thats all I found in web and make many times copy and paste to get this result. It's working, but not make job I want to get. Macro copy all data from all worksheets and insert it as new worksheets in this workbook "Data.xls".
I have of course more files to import. All have different names, but names of worksheet from which I wonder to get data is this same in all files.

I am really appreciate for any help which will bring to solve my problem.

Option Explicit

Public Sub ImportData()
    Call Load(ThisWorkbook, ThisWorkbook.Path & "\Data")
End Sub

Sub Load(WBookTarget As Excel.Workbook, _
            ByVal sPath As String)
    On Error GoTo Load_Error
    Dim oCollFiles                 As New VBA.Collection
    Dim WBookTmpSource             As Excel.Workbook
    Dim WksTarget                  As Excel.Worksheet
    Dim strFilesInPath             As String
    Dim strName                    As String
    Dim f                          As Long
    Dim w                          As Long
    Dim lngTmpLastRow              As Long
    Dim lngTmpLastColl             As Long
    Dim bRes                       As Boolean
    
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    strFilesInPath = Dir(sPath & "*.xlsx", vbNormal)    '  xlsx *****  uwaga
    If strFilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If
    Do While strFilesInPath <> ""
        If LCase(Right(strFilesInPath, 5)) = ".xlsx" Then
            oCollFiles.Add strFilesInPath
        End If
        strFilesInPath = Dir()
    Loop
    Application.CutCopyMode = False
    Call BlockEvScreenCalc(False)
    For f = 1 To oCollFiles.Count
        strName = oCollFiles.Item(f)
        Set WBookTmpSource = Application.Workbooks.Open(sPath & oCollFiles.Item(f))
        With WBookTmpSource
            For w = 1 To .Worksheets.Count
                With .Worksheets(w)
                    lngTmpLastRow = LastRowCol(.UsedRange)
                    If lngTmpLastRow > 0 Then
                        strName = .Name
                        lngTmpLastColl = LastRowCol(.UsedRange, False)
                        Set WksTarget = GetWorkSheet(WBookTarget, strName)
                        If WksTarget Is Nothing Then
                            Set WksTarget = WBookTarget.Worksheets.Add(After:=WBookTarget.Worksheets(WBookTarget.Worksheets.Count))
                            WksTarget.Name = strName
                            .Cells(1, 1).Resize(lngTmpLastRow, lngTmpLastColl).Copy
                            WksTarget.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            WksTarget.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                            Application.CutCopyMode = False
                        Else
                            Select Case True
                                Case LastRowCol(WksTarget.Cells) = 0
                                    .Cells(1, 1).Resize(lngTmpLastRow, lngTmpLastColl).Copy
                                    WksTarget.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                    WksTarget.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                    Application.CutCopyMode = False
                                Case lngTmpLastRow > 1
                                    WksTarget.Rows(2).Resize(lngTmpLastRow - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
                                    .Cells(2, 1).Resize(lngTmpLastRow - 1, lngTmpLastColl).Copy
                                    WksTarget.Cells(2, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                    WksTarget.Cells(2, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                                    Application.CutCopyMode = False
                            End Select
                            DoEvents
                        End If
                    End If
                End With
            Next
            .Close SaveChanges:=False
        End With
    Next
    bRes = True
    '----------------------------------------
Load_Exit:
    On Error Resume Next
    Application.CutCopyMode = False
    Call BlockEvScreenCalc(True)
    If bRes Then MsgBox "OK. Import files success!"
    Exit Sub

Load_Error:
    MsgBox "Error number: " & Err.Number & vbNewLine & _
           "Description: " & Err.Description & vbNewLine & _
           "Procedure: Download", vbExclamation
    Resume Load_Exit
    '  Resume
End Sub