How to merge multiple workbooks into one based on workbooks names

Question

I am about preparing reports for manager. I have multiple excel files (always with one sheet) I would need to merge sheets to one workbook with multiple sheets (called the same as original workbook) based on name of original files.

I need it to check the name of the file and based on the first four characters merge those files which have that characters the same. Then I want the new workbook to save with the name of those four characters.

for example i have in one folder these files->

1111_AB_ABC

1111_BC_AAA

1222_CD_BBB

1222_KL_XXX

1222_HJ_OPD

1666_HA_BNN

etc (there are around 300files like this, mostly there are 3 files with the same number at the beginning but there are few numbers for which I have four or five files). Is there any possibility how to do this?

I found some posts to merging workbooks to one masterfile, but nothing which is about merging files based on file name.

Answer 1

I'll give you some high-level ideas.

In order to achive what you want, you have to do:

• parse entire directory and retreive all files it contains
• extract substring from file name
• create new workbook with a given name

• save a workbook.

  Dim w as Workbook           ' workbook that will contain the sheets
  Dim tempWork as Workbook
  Dim rootFolder          ' the folder containing your files
  Dim fs                  ' represent FileSystem object
  Dim folder              ' represent folder object 
  Dim files               ' represent all files in a folder
  Dim file                ' represent a file object
  
  rootFolder = "C:\path\To\my\folder"
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set folder = fs.GetFolder(rootFolder)
  Set files = folder.Files           ' retrieve only files in rootFolder
  
  
  For Each file In files
    ' here "file" represent a file in rootFolder
    fileName = file.Name
    firstFourChar = Mid(fileName,1,4)   ' with Mid buil-in function you extract   sub string
  
    ' your business logic goes here
  
  next 
  

  ' For creating a new Workbook you may use:

  Dim w as Workbook
  Set w = Workbooks.Add
  

  ' For saving a Workbook:

  w.save ("path where save")
  

  ' For Opening a Workbook:

  Set w = Workbooks.Open(rootFolder & "\" & file.Name)
  

More information on Microsoft visual basic help:

Answer 2

Below is the code to do this.

As a parameter you need to pass the path to the source folder and the destination folder where the result files should be saved.

Note that folder paths must include slash at the end. You can later modify this function to check if the folder path contains slash at the end, and add it automatically if it doesn't.

Sub test(sourceFolder As String, destinationFolder As String)
    Const TO_DELETE_SHEET_NAME As String = "toBeDeleted"
    '------------------------------------------------------------------
    Dim settingSheetsNumber As Integer
    Dim settingDisplayAlerts As Boolean
    Dim dict As Object
    Dim wkbSource As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim filepath As String
    Dim code As String * 4
    Dim wkbDestination As Excel.Workbook
    Dim varKey As Variant
    '------------------------------------------------------------------


    'Change [SheetsInNewWorkbook] setting of Excel.Application object to
    'create new workbooks with a single sheet only.
    With Excel.Application
        settingDisplayAlerts = .DisplayAlerts
        settingSheetsNumber = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
        .DisplayAlerts = False
    End With


    Set dict = VBA.CreateObject("Scripting.Dictionary")


    filepath = Dir(sourceFolder)

    'Loop through each Excel file in folder
    Do While filepath <> ""

        If VBA.Right$(filepath, 5) = ".xlsx" Then

            Set wkbSource = Excel.Workbooks.Open(sourceFolder & filepath)
            Set wks = wkbSource.Worksheets(1)
            code = VBA.Left$(wkbSource.Name, 4)


            'If this code doesn't exist in the dictionary yet, add it.
            If Not dict.exists(code) Then
                Set wkbDestination = Excel.Workbooks.Add
                wkbDestination.Worksheets(1).Name = TO_DELETE_SHEET_NAME
                Call dict.Add(code, wkbDestination)
            Else
                Set wkbDestination = dict.Item(code)
            End If

            Call wks.Copy(Before:=wkbDestination.Worksheets(1))
            wkbDestination.Worksheets(1).Name = VBA.Mid$(filepath, 6)

            Call wkbSource.Close(False)

        End If

        filepath = Dir

    Loop


    'Save newly created files.
    For Each varKey In dict.keys
        Set wkbDestination = dict.Item(varKey)

        'Remove empty sheet.
        Set wks = Nothing
        On Error Resume Next
        Set wks = wkbDestination.Worksheets(TO_DELETE_SHEET_NAME)
        On Error GoTo 0

        If Not wks Is Nothing Then wks.Delete


        Call wkbDestination.SaveAs(Filename:=destinationFolder & varKey & ".xlsx")


    Next varKey


    'Restore Excel.Application settings.
    With Excel.Application
        .DisplayAlerts = settingDisplayAlerts
        .SheetsInNewWorkbook = settingSheetsNumber
    End With


End Sub