Hi I've tried to merge multiple reports into one without success, first I set the code to let the user enter the path where folder containing multiple reports is located, and then put the code to open all and copy and paste in a new one, but no success.. VBA is not able to recognize second part and open the files.

Sub files()
Dim folderpath As String
Dim FileOpen As String
Dim DialogBox As FileDialog
Dim wbk As Workbook
Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim Filename As String

folderpath = InputBox("Please introduce the path where files are stored", "Select Files' Path", "Paste path here")
FileOpen = Dir(folderpath & "\*.xls*")
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(FileOpen)
wbk.Activate

Range(“A1”).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Windows(“Book1”).Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(“Sheet1”).Cells(Rows.Count, 1).End(xlUp).Row
Sheets(“Sheet1”).Select
Cells(lr   1, 1).Select
ActiveSheet.Paste
wbk.Close True
Filename = Dir
Loop

End Sub*

CodePudding user response：

Copy Worksheets' Ranges to a New Workbook

Option Explicit

Sub CreateReport()
    
    Dim sFolderPath As String
    sFolderPath = InputBox("Please introduce the path where files are stored", _
        "Select Files' Path", "Paste path here")
    If Len(sFolderPath) = 0 Then Exit Sub
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    
    Dim sFilename As String: sFilename = Dir(sFolderPath & "*.xls*")
    If Len(sFilename) = 0 Then Exit Sub
    
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
    Dim dws As Worksheet: Set dws = dwb.Worksheets(1)
    Dim dfCell As Range
    Set dfCell = dws.Range("A1")
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim sFilePath As String
    Dim sCount As Long
    
    Do While Len(sFilename) > 0
        Set swb = Workbooks.Open(sFolderPath & sFilename)
        On Error Resume Next ' test if the worksheet exists
            Set sws = swb.Worksheets("Sheet1")
        On Error GoTo 0
        If Not sws Is Nothing Then ' worksheet exists
            sCount = sCount   1
            If sCount = 1 Then ' with headers
                Set srg = sws.Range("A1").CurrentRegion
            Else ' without headers
                With sws.Range("A1").CurrentRegion
                    Set srg = .Resize(.Rows.Count - 1).Offset(1)
                End With
            End If
            srg.Copy dfCell
            Set dfCell = dfCell.Offset(srg.Rows.Count)
            Set sws = Nothing
        'Else ' worksheet doesn't exist
        End If
        swb.Close SaveChanges:=False
        sFilename = Dir
    Loop

    MsgBox "Report created out of " & sCount & " worksheets.", _
        vbInformation, "CreateReport"

End Sub