How to split data from multiple worksheets based on column into multiple workbooks in Excel?

Question

A slight twist on 2 popular question asked in these forums...

I am trying to split a Excel workbook into multiple workbooks based on different column value(lets call them saleTeam1, saleTeam2,saleTeam3).

However, the subject workbook has multiple worksheets, each reporting different metrics for the different sales teams: the only common denominator between the worksheets are the sales teams, indicated on the first columns of each worksheet.

I use 2 VBA macros for different other tasks:

1)parse target worksheet into multiple worksheets based on unique values in column A, and

2)split a workbook and create new workbooks for each unique worksheet.

Trying to integrate the 2 functions together but I feel it may be more worthwhile to build it from scratch. However, I can't wrap my head around an efficient solution.

    Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

'set split target column
vcol = 1

' set split target sheet
Set ws = Sheets("Sheet1")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:M1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Sub SplitWB()
Dim xlApp As Object
Dim wbSource As Object
Dim wbNew As Object
Dim ws As Worksheet
Dim strFileName As String

    ' change path and filename here
    strFileName = "C:\Users\username\Documents\split\split.xlsx"

    Set xlApp = CreateObject("Excel.Application")

    Set wbSource = xlApp.Workbooks.Open(strFileName)

    For Each ws In wbSource.Worksheets
         ws.Copy
         Set wbNew = xlApp.ActiveWorkbook
         wbNew.SaveAs wbSource.Path & xlApp.PathSeparator & ws.Name & ".xlsx"
         wbNew.Close
         Set wbNew = Nothing
    Next ws

    wbSource.Close SaveChanges:=False
    Set wbSource = Nothing

    xlApp.Quit
    Set xlApp = Nothing

End Sub

Bottom line: trying to make 1 workbook(with 5 worksheets with varying columns) with 6 teams data, into 6 workbooks(each with same 5 worksheets as original workbook) with each team's data separate

A.S.H A.S.H · Accepted Answer · 2017-04-19T00:32:03

I didn't like the idea of grouping your two functions, I prefer to first get teams using a dictionary then create a WB for each team and use Excel's filtering capabilities. Try it like this:

Sub SplitWB()
    Application.EnableEvents = False: Application.ScreenUpdating = False: Application.DisplayAlerts = True
    On Error GoTo Cleanup

    Dim ws As Worksheet, wb As Workbook, team
    For Each team In getTeams
        Set wb = Workbooks.Add ' create a wb for each team with same # of sheets
        Do Until wb.Worksheets.count >= ThisWorkbook.Worksheets.count
            wb.Worksheets.Add After:=wb.Sheets(wb.Sheets.count)
        Loop

        For Each ws In ThisWorkbook.Worksheets
            With ws.UsedRange
                .AutoFilter 1, team ' filter to copy only the team's rows
                .Copy wb.Sheets(ws.Index).Range("A1")
                .AutoFilter
            End With
            wb.Sheets(ws.Index).name = ws.name & "_" & team
        Next
        wb.SaveAs ThisWorkbook.path & "\" & team & ".xlsx"
        wb.Close False
    Next

Cleanup:
    Application.EnableEvents = True: Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Function getTeams() ' gets the unique team names using a dictionary
    Dim cel As Range, dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("Sheet1")
        For Each cel In .Range("A2:A" & .Cells(.Rows.count, "A").End(xlUp).row)
            If Len(Trim(cel.Value2)) > 0 Then dict(cel.Value2) = 0
        Next
    End With
    getTeams = dict.Keys
End Function

How to split data from multiple worksheets based on column into multiple workbooks in Excel?

1 Answers