VBA code to split an excel file into multiple work

Question

I'm not experienced with VBA, but I think it's the only way for this to work.

I need to send a report to each sales team, but don't want to send them the information of other sales team. There are multiple sheets per workbook with different reports which all have a sales team column.

I would like all the sheets to be filtered by sales team, and create a new workbook for each team.

I appreciate any help.

Answer 1

I have written a VBA(Macro) program which will work based on Input data. All you need to do is, provide input data in a column in another sheet. Macro will read the data and filter Master Sheet based on each row then it Generate new excel sheet based on find data.

enter Option Explicit
Dim personRows As Range     'Stores all of the rows found                               

'Split data into separate columns baed on the names defined in
'a RepList on the 'Names' sheet.
Sub SplitSalesData()
Dim wb As Workbook
Dim p As Range
Dim counter2 As Integer
Dim i As Integer
counter2 = 0
i = 0
Application.ScreenUpdating = False

    ' in my case i am generating new excel based on every 8 reacords from begining. You can simplyfy this logic based on your need.

        For Each p In Sheets("Names").Range("RepList") ' Give the name of your input sheet and column
            If i = 0 Then                              ' We are starting, so generate new excel in memeory.
                Workbooks.Add
                Set wb = ActiveWorkbook
                ThisWorkbook.Activate
            End If
            WritePersonToWorkbook wb, p.Value
            i = i + 1   ' Increment the counter reach time
            If i = 8 Then   ' As my need is after processing every 8 uniqe record just save the excel sheet and reset the processing
                counter2 = counter2 + 1
                wb.SaveAs ThisWorkbook.Path & "\salesdata_" & CStr(counter2)   ' save the data at current directory location.
                wb.Close
                Set personRows = Nothing  ' Once the process has completed for curent excelsheet, set the personRows as NULL
                i = 0
            End If
        Next p

Application.ScreenUpdating = True
Set wb = Nothing
End Sub

'Writes all the data rows belonging to a RepList
Sub WritePersonToWorkbook(ByVal SalesWB As Workbook, _
                      ByVal Person As String)
Dim rw As Range
Dim firstRW As Range

For Each rw In UsedRange.Rows
    If Not Not firstRW Is Nothing And Not IsNull(rw) Then
        Set firstRW = rw  ' WE want to add first row in each excel sheet.
    End If
    If Person = rw.Cells(1, 5) Then  ' My filter is working based on "FeederID"
        If personRows Is Nothing Then
            Set personRows = firstRW
            Set personRows = Union(personRows, rw)
        Else
            Set personRows = Union(personRows, rw)
        End If
    End If
Next rw
personRows.Copy SalesWB.Sheets(1).Cells(1, 1) ' Adding data in Excel sheet.
End Sub

Answer 2

I got this solution.
Just send me an email if you need this solution.

At first I got this format:

I create the following macro code

Option Explicit
Dim MainWorkBook As Workbook
Dim NewWorkBook As Workbook

Sub ExportWorksheet()
Dim Pointer As Long

Set MainWorkBook = ActiveWorkbook
Range("E2").Value = MainWorkBook.Sheets.Count

Application.ScreenUpdating = False   'enhance the performance
For Pointer = 2 To MainWorkBook.Sheets.Count
    Set NewWorkBook = Workbooks.Add
    MainWorkBook.Sheets(Pointer).Copy After:=NewWorkBook.Sheets(1)
    Application.DisplayAlerts = False
    NewWorkBook.Sheets(1).Delete
    Application.DisplayAlerts = True
    With NewWorkBook
        .SaveAs Filename:="C:\Users\lengkgan\Desktop\Testing\" & MainWorkBook.Sheets(Pointer).Name & ".xls" 'you may change to yours
    End With
    NewWorkBook.Close SaveChanges:=True
Next Pointer

Application.ScreenUpdating = True
Range("D5").Value = "Export Completed"

End Sub

Following is the output