Merge many Excel Worksheets into one using VBS

Download MergeSheets2.zip

Using the Code

You can drag and drop Excel files on top of this script file to merge them. The first data row must contain column names. Columns with no column name will be skipped.

The script will create a new "Combined" sheet at the beginning. Column can be different between worksheets. If the next worksheet will contain a column name not present in the previous sheets, a new column will be added.

if WScript.Arguments.Count = 0 then
    MsgBox "Please drag and drop an excel file on top of this script file to merge sheets."
    WScript.Quit
End If

Set fso = CreateObject("Scripting.FileSystemObject")
sFilePath = WScript.Arguments(0)

If fso.FileExists(sFilePath) = False Then
  MsgBox "Could not file Excel file: " & sFilePath & " to merge sheets"
  WScript.Quit
End If

If MsgBox("Merge worksheets for this file: " & sFilePath, vbYesNo + vbQuestion) = vbNo Then
  WScript.Quit
End If

Dim dic: Set dic = CreateObject("Scripting.Dictionary")
Dim oExcel: Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = True
oExcel.DisplayAlerts = false
Set oWorkBook = oExcel.Workbooks.Open(sFilePath)

Set oCombined = oWorkBook.Worksheets.Add(oWorkBook.Worksheets(1))
oCombined.Name = "Combined"
dic("Sheet Name") = 1
oCombined.Cells(1, 1).Value = "Sheet Name"
oCombined.Cells(1, 1).EntireRow.Font.Bold = True
iRowOffset = 0

For Each oSheet in oWorkBook.Worksheets
    If oSheet.Name <> "Combined" Then
        iRowsCount = GetLastRowWithData(oSheet)

        For iRow = 1 to iRowsCount
            If iRow = 1 And iRowOffset = 0 Then
                'Sheet Name header
            Else
                oCombined.Cells(iRow + iRowOffset, 1).Value = oSheet.Name
            End If
        Next

        For iCol = 1 to oSheet.UsedRange.Columns.Count
            sCol = trim(oSheet.Cells(1, iCol).Value & "")

            If sCol <> "" Then 'Skip columns with no data
                
                If dic.Exists(sCol) Then
                    iDestCol = dic(sCol)
                Else
                    iDestCol = dic.Count + 1
                    dic(sCol) = iDestCol
                    oCombined.Cells(1, iDestCol).Value = sCol
                End If

                For iRow = 2 to iRowsCount
                    oCombined.Cells(iRow + iRowOffset, iDestCol).Value = _
                                           oSheet.Cells(iRow, iCol).Value
                Next
            End If
        Next
        
        iRowOffset = iRowOffset + iRowsCount - 1
    End If
Next

MsgBox "Done!"

Function GetLastRowWithData(oSheet)
    iMaxRow = oSheet.UsedRange.Rows.Count
    If iMaxRow > 500 Then
        iMaxRow = oSheet.Cells.Find("*", oSheet.Cells(1, 1),  -4163, , 1, 2).Row
    End If

    For iRow = iMaxRow to 1 Step -1
         For iCol = 1 to oSheet.UsedRange.Columns.Count
            If Trim(oSheet.Cells(iRow, iCol).Value) <> "" Then
                GetLastRowWithData = iRow
                Exit Function
            End If
         Next
    Next
    GetLastRowWithData = 1
End Function

Function GetLastCol(st)
    GetLastCol = st.Cells.Find("*", st.Cells(1, 1), , 2, 2, 2, False).Column
End Function

The script will merge worksheets with the same columns. It is much faster than the script because it does copy and paste.

if WScript.Arguments.Count = 0 then
    MsgBox "Please drag and drop an excel file on top of this script file to merge sheets."
    WScript.Quit
End If

Set fso = CreateObject("Scripting.FileSystemObject")
sFilePath = WScript.Arguments(0)

If fso.FileExists(sFilePath) = False Then
  MsgBox "Could not file Excel file: " & sFilePath & " to merge sheets"
  WScript.Quit
End If

If MsgBox("Merge worksheets for this file: " & sFilePath, vbYesNo + vbQuestion) = vbNo Then
  WScript.Quit
End If

Dim oExcel: Set oExcel = CreateObject("Excel.Application")
oExcel.Visible = True
oExcel.DisplayAlerts = false
Set oWorkBook = oExcel.Workbooks.Open(sFilePath)

Set oCombined = oWorkBook.Worksheets.Add(oWorkBook.Worksheets(1))
oCombined.Name = "Combined"
oCombined.Cells(1, 1).Value = "Sheet Name"
oCombined.Cells(1, 1).EntireRow.Font.Bold = True
iRowOffset = 0

For Each oSheet in oWorkBook.Worksheets
    If oSheet.Name <> "Combined" Then
        iRowsCount = GetLastRowWithData(oSheet)

        If iRowOffset = 0 Then 
            iStartRow = 1
        Else 
            iStartRow = 2
        end if

        oSheet.Range(oSheet.Cells(iStartRow, 1), oSheet.Cells(iRowsCount, oSheet.UsedRange.Columns.Count)).Copy
        oCombined.Activate
        oCombined.Cells(iRowOffset + 1, 1).Select
        oCombined.Paste       

        If iRowOffset = 0 Then 
            iRowOffset = iRowOffset + iRowsCount
        Else 
            iRowOffset = iRowOffset + iRowsCount - 1
        end if
    End If
Next

If MsgBox("Delete old tabs? ", vbYesNo + vbQuestion) = vbYes Then
    For Each oSheet in oWorkBook.Worksheets
        If oSheet.Name <> "Combined" Then
            oSheet.Delete
        End If
    Next
End If

MsgBox "Done!"

Function GetLastRowWithData(oSheet)
    iMaxRow = oSheet.UsedRange.Rows.Count
    If iMaxRow > 500 Then
        iMaxRow = oSheet.Cells.Find("*", oSheet.Cells(1, 1),  -4163, , 1, 2).Row
    End If

    For iRow = iMaxRow to 1 Step -1
         For iCol = 1 to oSheet.UsedRange.Columns.Count
            If Trim(oSheet.Cells(iRow, iCol).Value) <> "" Then
                GetLastRowWithData = iRow
                Exit Function
            End If
         Next
    Next
    GetLastRowWithData = 1
End Function

Function GetLastCol(st)
    GetLastCol = st.Cells.Find("*", st.Cells(1, 1), , 2, 2, 2, False).Column
End Function

History

• 5^th May, 2020: Initial version