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

You have lots of call functions.
I have adjusted the code to work with sheet named called "Person", but ONLY this section, and the code ,as you pointed that, copies all cells, you need to specify which cells you want to copy.

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.Worksheets("Person")
        
                    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

This is my understanding of your request.
You want to loop through the files and then copy the above cells from each book(sheet name person) in to new worksheet. Is this right? If it is, the code you have got some lines which you do not need for this purpose. For e.g. you have select case

Yes, you've right. I am beginner in VBA. This is absolutely new for me. I am learning on this case and cannot cope with this alone. It is many lines of codes which I found when looking any solutions in web. That's why there is possible too many codes. Please, show me which is not necessary.
After solve this case I am going to start deeply learn VBA. Unfortunately this solution I need faster then I can learn.

Okay! Will do

Thanks a lot. It works perfectly!

You wrote new lines of code. Wow. Respect for you and your knowledge.

I attach here all final job. Maybe someone else find here this solution.
Once again, many thanks.

Exangel7,
You are welcome!
Could you please now close (Mark) this thread as solved? Go to the top right-hand side of this page, choose "Thread Tools" from the menu, then select "solved" from the drop down menu.