How to Split a Workbook Based on a Column and Copy to the Workbook with the Same Column Value Using-CodePudding

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.

CodePudding user response：

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
    
    Set dict = CreateObject("Scripting.Dictionary")
    Set wbSrc = ActiveWorkbook
    
    Application.ScreenUpdating = False
    For Each ws In wbSrc.Worksheets
        If ws.Name <> "Open" Then
            For nRow = 2 To ws.Cells(Rows.Count, "A").End(xlUp).Row
                
                v = ws.Cells(nRow, Col).Value 'get the specific Column
                
                If Not dict.exists(v) Then    'need a new workbook?
                     'add new workbook with one sheet
                     Set wsTmp = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
                     ws.Rows(1).Copy wsTmp.Range("A1") 'copy headers
                     dict.Add v, wsTmp.Range("A2")     'add key and the forst paste destination
                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
    Next ws
    
    Workbooks("Open_Spreadsheet_Split.xlsm").Activate 'ThisWorkbook?
    Sheets(1).Activate
End Sub