How to Split a Workbook Based on a Column and Copy to the Workbook with the Same Column Value Using Excel VBA?

Question

Here is the sub I am using that splits loops through each tab and split them into multiple workbooks based on the user-specified column, "Manufacturer Name".

Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)      
 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

 Dim wsSheet As Worksheet

 For Each wsSheet In Worksheets
    If wsSheet.Name <> "Open" Then
        wsSheet.Activate
        
        Set objWorksheet = ActiveSheet
        nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
        
        Set objDictionary = CreateObject("Scripting.Dictionary")
        
        For nRow = 2 To nLastRow
           'Get the specific Column
           strColumnValue = objWorksheet.Range(Col & 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)

           'Create a new Excel workbook
           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 = 2 To nLastRow
              If CStr(objWorksheet.Range(Col & nRow).Value) = CStr(varColumnValue) Then
                 objWorksheet.Rows(nRow).EntireRow.Copy
    
                 nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
                 objSheet.Range("A" & nNextRow).Select
                 objSheet.Paste
                 objSheet.Columns("A:B").AutoFit
              End If
            Next
        Next
    
    End If
 Next wsSheet

 Workbooks("Open_Spreadsheet_Split.xlsm").Activate
 Sheets(1).Activate
End Sub

This is ending up making way too many workbooks. So instead, for each tab, I want to copy the rows with the same Manufacturer to the same workbook.

Answer 1

EDIT: make sure headers from each source sheet are included on each destination sheet.

Try this out:

Sub SplitSheetIntoMultWkbksBasedOnCol(Col As String)
    
    Dim wbSrc As Workbook, ws As Worksheet, wsTmp As Worksheet
    Dim dict As Object, lastRow As Long, nRow As Long, v
    Dim dictHeader As Object 'for tracking whether headers have been copied
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set wbSrc = ActiveWorkbook
    
    Application.ScreenUpdating = False
    For Each ws In wbSrc.Worksheets
        If ws.Name <> "Open" Then
            Set dictHeader = CreateObject("Scripting.Dictionary") 'reset header-tracking dictionary
            For nRow = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                
                v = ws.Cells(nRow, Col).Value 'get the specific Column
                
                'need a new workbook?
                If Not dict.exists(v) Then
                     Set wsTmp = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'add new workbook with one sheet
                     dict.Add v, wsTmp.Range("A1")     'add key and the first paste destination
                End If
                
                'first row from this sheet for this value of `v`?
                If Not dictHeader.exists(v) Then
                    ws.Rows(1).Copy dict(v)            'copy headers from this sheet
                    Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
                    dictHeader.Add v, True             'flag header as copied
                End If
                
                ws.Rows(nRow).Copy dict(v)         'copy the current row
                Set dict(v) = dict(v).Offset(1, 0) 'set next paste position
            Next nRow
        End If 'not "open" sheet
    Next ws
    
    Workbooks("Open_Spreadsheet_Split.xlsm").Activate 'ThisWorkbook?
    Sheets(1).Activate
End Sub