Consolidating various workbooks in one VBA

Kris_Toor 0
Viewed 26

I have a task - consolidate various documents (the number of those might differ) from one folder into one master data.

Each document is based on a template so they look exactly the same, each with two sheets, but their names are different.

I need ONLY one of those sheets to be copied, named "Fill this out".

So optimal solution would be: Master data workbook, with as many worksheets as there are files in the folder, and each sheet containing data ONLY from "Fill this out" sheet.

My current code:

Sub MergeWorkbooks()

Dim FolderPath As String
Dim File As String

FolderPath = "C:\Users\" & Environ("username") & "\Downloads\BH\"

File = Dir(FolderPath)

Do While File <> ""

    Workbooks.Open FolderPath & File
        ActiveWorkbook.Worksheets("Fill this out").Copy _
            after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            ActiveSheet.Name = File
            Workbook.Close FolderPath & File
            
    File = Dir()

Loop

End Sub

Copies only first file and then error 400 pops out.

Additionally, the new sheet name is: "Fill this out" in stead of file name.

Please help.

vba excel
1 Answers

You can use this code to open the files in that folder, and close each one of them dismissing the respective save event. Note the "*.xl*" filter to only allow opening Excel files:

Option Explicit

Sub MergeWorkbooks()
    Dim FolderPath As String
    Dim File As String

    FolderPath = "C:\Users\" & Environ("username") & "\Downloads\BH\"

    File = Dir(FolderPath & "*.xl*")

    Do While File <> ""

        Workbooks.Open FolderPath & File
        ActiveWorkbook.Worksheets("Fill this out").Copy _
            after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ActiveSheet.Name = File
        Workbooks(File).Close savechanges:=False
            
        File = Dir()

    Loop

End Sub

EDIT

Try this modified code, which is more assertive dealing with the source workbooks (setting a Workbook object):

Option Explicit

Sub MergeWorkbooks()
    Dim FolderPath As String
    Dim File As String
    Dim objWB As Excel.Workbook

    FolderPath = "C:\Users\" & Environ("username") & "\Downloads\BH\"

    File = Dir(FolderPath & "*.xl*")

    Do While File <> ""

        Set objWB = Workbooks.Open(FolderPath & File)
       
        If Not objWB Is Nothing Then
            objWB.Worksheets("Fill this out").Copy _
                after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            ThisWorkbook.Sheets("Fill this out").Name = File
            objWB.Close savechanges:=False
        End If
   
        File = Dir()

    Loop

End Sub
ALeXceL0
Related