Using VBA how do I combine multiple (over 100) excel files into one?-CodePudding

-very new to VBA and coding in general so this is probably a dumb question but cannot find work resources to help-

I am merging multiple excel files into one, that cannot be turned into CVS as they have multiple sheets (all the same number of sheets in each workbook and in the same order) and I need the 3rd sheet in the workbook.

I have tried using this code: That I got online but I keep getting errors on the path = GetDirectory("Select a folder containing Excel files you want to merge"). It is driving me crazy.

Thanks for any help in advance!

Merge Workbooks

Sub MergeWBs()
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer

    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

    ThisWB = ActiveWorkbook.Name
    
    path = GetDirectory("Select a folder containing Excel files you want to merge")

    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xlsm", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
            Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
            Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row   1)
            CopyRng.Copy Dest
            Wkb.Close False
        End If
        
        Filename = Dir()
    Loop
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    MsgBox "Macro Complete"
End Sub

CodePudding user response：

GetDirectory() was probably not copied over with the rest of the code.

Here is my replacement function:

Public Function GetDirectory(Optional Title As String = "Select a Folder.", Optional InitialFileName As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = Title
        .InitialFileName = InitialFileName
        If .Show = -1 Then
            GetDirectory = .SelectedItems(1)
        End If
    End With
End Function

CodePudding user response：

Import Data

Option Explicit

Sub MergeWorkbooks()
    
    Const SRC_FILE_PATTERN As String = "*.xlsm"
    Const SRC_SHEET_ID As Variant = 3
    Const SRC_FIRST_ROW As Long = 2
    Const DST_WORKSHEET_ID As Variant = 1
    Const DST_FIRST_CEll As String = "A2"
    
    Application.ScreenUpdating = False

    Dim FolderPath As String: FolderPath = PickFolder()
    If Len(FolderPath) = 0 Then Exit Sub
    
    Dim sFileName As String: sFileName = Dir(FolderPath & SRC_FILE_PATTERN)
    If Len(sFileName) = 0 Then
        MsgBox "No files found in '" & FolderPath & "'.", vbCritical
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DST_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CEll)
    Dim dlCell As Range
    Set dlCell = dws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If Not dlCell Is Nothing Then
        If dlCell.Row >= dfCell.Row Then
            Set dfCell = dlCell.Offset(1).EntireRow.Columns(dfCell.Column)
        End If
    End If
    
    Dim swb As Workbook, sws As Worksheet, srg As Range
    Dim srOffset As Long, srCount As Long
    
    Do While Len(sFileName) > 0
        Set swb = Workbooks.Open(FolderPath & sFileName, True, True)
        On Error Resume Next
            Set sws = swb.Sheets(SRC_SHEET_ID)
        On Error GoTo 0
        If Not sws Is Nothing Then ' worksheet found
            With sws.UsedRange
                srOffset = SRC_FIRST_ROW - 1
                srCount = .Rows.Count - srOffset
                If srCount > 0 Then
                    Set srg = .Resize(srCount).Offset(srOffset)
                    srg.Copy dfCell
                    Set dfCell = dfCell.Offset(srCount)
                End If
            End With
            Set sws = Nothing ' reset for the next iteration
        'Else ' worksheet not found; do nothing
        End If
        swb.Close SaveChanges:=False
        sFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Data imported.", vbInformation

End Sub

Function PickFolder( _
    Optional ByVal InitialFolderPath As String = "", _
    Optional ByVal DialogTitle As String = "Browse", _
    Optional ByVal DialogButtonName As String = "OK") _
As String
    With Application.FileDialog(4) ' 4 = msoFileDialogFolderPicker
        .Title = DialogTitle
        .ButtonName = DialogButtonName
        Dim pSep As String: pSep = Application.PathSeparator
        Dim FolderPath As String
        If Len(InitialFolderPath) > 0 Then
            FolderPath = InitialFolderPath
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
            .InitialFileName = FolderPath
        End If
        If .Show Then
            FolderPath = .SelectedItems(1)
            If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
            PickFolder = FolderPath
        Else
            ' Optionally, out-comment or use a message box.
            Debug.Print "'PickFolder': Dialog canceled."
        End If
    End With
End Function