Trying to merge workbooks in a folder, but converting from a full sheet to a range

[whazzzzzupp17]

I’m looking for some help in converting my current code into a range instead of a full sheet


Instead of merging sheet 1 from multiple workbooks into a master workbook, I only need to copy a specific range on sheet one of each workbook and paste it within the master workbook. I need each sheet in the master workbook to have the original sheet name from sheet1 from the workbooks.

Sub MergeMultipleWorkbooks()


'Declare variables
    Dim Path
    FileName As String
    Dim was As Worksheet


' Disable updates to increase performance.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
'Set path and file extensions
    Path = "D:\Workbooks\"
    FileName = Dir(Path & "*.xlsm")


'Start of loop
    Do While FileName <> "" 'Open if filename has a name


        With Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
            .Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
            .Close False
        End With


        FileName = Dir()
    Loop
    
' Re-enable updating.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Files has been copied Successfully", , "MergeMultipleExcelFiles"
End Sub

 

[DanteAmor]

try this

Sub MergeMultipleWorkbooks()




'Declare variables
    Dim Path
    Dim FileName As String
    Dim was As Worksheet
    
[COLOR=#0000ff]    Dim sh_Name As String[/COLOR]
[COLOR=#0000ff]    Dim sh_t As Worksheet[/COLOR]
[COLOR=#0000ff]    Dim exists As Boolean[/COLOR]




' Disable updates to increase performance.
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
'Set path and file extensions
    Path = "D:\Workbooks\"
    FileName = Dir(Path & "*.xlsm")




'Start of loop
    Do While FileName <> "" 'Open if filename has a name


        exists = False
        With Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
            '.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
[COLOR=#0000ff]            'copy a specific range[/COLOR]
[COLOR=#0000ff]            sh_Name = .Worksheets(1).Name[/COLOR]
[COLOR=#0000ff]            For Each sh_t In ThisWorkbook.Sheets[/COLOR]
[COLOR=#0000ff]                If LCase(sh_t.Name) = LCase(sh_Name) Then[/COLOR]
[COLOR=#0000ff]                    exists = True[/COLOR]
[COLOR=#0000ff]                    Exit For[/COLOR]
[COLOR=#0000ff]                End If[/COLOR]
[COLOR=#0000ff]            Next[/COLOR]
[COLOR=#0000ff]            If exists = True Then[/COLOR]
[COLOR=#0000ff]                .Worksheets(1).Range("A1:D10").Copy[/COLOR]
[COLOR=#0000ff]                ThisWorkbook.Sheets(sh_Name).Range("A1").PasteSpecial xlValues[/COLOR]
[COLOR=#0000ff]            End If[/COLOR]
            .Close False
        End With




        FileName = Dir()
    Loop
    
' Re-enable updating.
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "Files has been copied Successfully", , "MergeMultipleExcelFiles"
End Sub