Split worksheet into multiple workbooks keeping the top rows intact on each workbook

Question

The code was working until I added subtotals in the top rows.

How can I split the worksheet into multiple workbooks keeping the top rows intact on each workbook?

The rows on top to transfer to each new workbook:

Expected output:

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objExcelWorkbook As Excel.Workbook
    Dim objSheet As Excel.Worksheet
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range("A" & nRow).Value
        If objDictionary.Exists(strColumnValue) = False Then
            objDictionary.Add strColumnValue, 1
        End If
    Next
    varColumnValues = objDictionary.Keys
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objExcelWorkbook = Excel.Application.Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        objWorksheet.Rows(1).EntireRow.Copy
        objSheet.Activate
        objSheet.Range("A1").Select
        objSheet.Paste
        For nRow = 9 To nLastRow
            strColumnValue = objWorksheet.Range("A" & nRow).Value
            If objDictionary.Exists(strColumnValue) = False Then
                objDictionary.Add strColumnValue, 1
            End If
        Next
        If CStr(objWorksheet.Range("A" & nRow).Value) = CStr(varColumnValue) Then
            objWorksheet.Rows(nRow).EntireRow.Copy
            nNextRow = objSheet.Range("AD" & objWorksheet.Rows.Count).End(xlUp).Row + 1
            objSheet.Range("A" & nNextRow).Select
            objSheet.Paste
            objSheet.Columns("A:AF").AutoFit
        End If
    Next
    ' Save the new workbook in a specific location
    savePath = "file path" ' Specify the save path here
    objExcelWorkbook.SaveAs savePath & varColumnValue & ".xlsx"
    objExcelWorkbook.Close

End Sub

I get an error on

objSheet.Name = varColumnValue

Answer 1

• For nRow = 2 To nLastRow the cells (from row 2 to row 7) are blank in Col A. There is a blank item in the Dict object. objSheet.Name = varColumnValue raises runtime error if varColumnValue="".

• nRow = 2 is used in your code. I guess there is a header line. Change the start number of For loop to 9.

    For nRow = 9 To nLastRow
        strColumnValue = objWorksheet.Range("A" & nRow).Value
        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next

---

Update:

Option Explicit

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Worksheet
    Dim nLastRow As Long, nRow As Long
    Dim nColCnt As Long, rowRng As Range
    Dim strColValue As String, savePath As String
    Dim objDic As Object, i As Long
    Dim varColValues As Variant
    Dim varColValue As Variant
    Dim objExcelWorkbook As Workbook
    Dim objSheet As Worksheet
    Const H_ROW = 8 ' header row#
    Set objWorksheet = ActiveSheet
    With objWorksheet
        nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        nColCnt = .Cells(H_ROW, .Columns.Count).End(xlToLeft).Column
        Set objDic = CreateObject("Scripting.Dictionary")
        ' Loop through data
        For nRow = H_ROW + 1 To nLastRow
            strColValue = Trim(.Range("B" & nRow).Value)
            If Len(strColValue) > 0 Then
                ' Store data range in Dict
                Set rowRng = .Cells(nRow, 1).Resize(1, nColCnt)
                If objDic.Exists(strColValue) Then
                    Set objDic(strColValue) = Union(rowRng, objDic(strColValue))
                Else
                    Set objDic(strColValue) = rowRng
                End If
            End If
        Next
    End With
    varColValues = objDic.Keys
    For i = LBound(varColValues) To UBound(varColValues)
        varColValue = varColValues(i)
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        ' Copy header and above rows
        objWorksheet.Rows("1:" & H_ROW).Copy objSheet.Range("A1")
        ' Copy data rows
        objDic(varColValue).Copy objSheet.Cells(H_ROW + 1, 1)
        ' Save the new workbook in a specific location
        savePath = "H:\01 - Merit\2024 Merit\Merit Spreadsheets\AP Copies\" ' Specify the save path here
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close
    Next
End Sub