Macro To Import Data From Multiple Workbook Sheets In A Folder

[Admin]

Hi

Try this

Option Explicit

Sub kTest()
    
    Dim wbkActive   As Workbook
    Dim wbkOpened   As Workbook
    Dim strFName    As String
    Dim strFolder   As String
    Dim strWkSht    As String
    
    Const ImportRange   As String = "B5:K22"    '<<<<< adjust this range
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            strFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    Set wbkActive = ThisWorkbook
    Application.ScreenUpdating = 0
    strFName = Dir(strFolder & "\*.xls*")
    
    Do While strFName <> vbNullString
        If strFName <> wbkActive.Name Then
            Set wbkOpened = Workbooks.Open(strFolder & "\" & strFName, 0)
            strWkSht = Left(strFName, InStrRev(strFName, ".") - 1)
            On Error Resume Next
            wbkOpened.Worksheets(1).Range(ImportRange).Copy wbkActive.Worksheets(strWkSht).Range("a1")
            If Err.Number <> 0 Then
                MsgBox "Worksheet '" & strWkSht & "' couldn't found!", vbCritical
            End If
            Err.Clear: On Error GoTo 0
            wbkOpened.Close 0
            Set wbkOpened = Nothing
        End If
        strFName = Dir()
    Loop
    Application.ScreenUpdating = 1
    
End Sub