MS Excel - Split data from one sheet to different sheets based on a column

Recently we have had a small issue with the BI Publisher and we had to run a report manually and implement the Bursting technique somehow to split the data generated by the Data Model ,so that we can email the report to the respective Users.

We ran the SQL used in the data model against the EBS  and was able to get the data for all the users.Now the primary agenda here is to split the data on user basis and send them their data respectively.

Lets say my Excel Workbook has one sheet "Sheet1" and has the below columns

USER_ID 

USER_NAME

USER_EMAIL

USER_CITY

USER_COUNTRY

CALENDAR_DATE

USER_ACTIVITY

We have two steps here 

1. Split the data from Sheet1 into multiple sheets based on USER_ID in the same workbook
2. Split the created sheets of workbook into separate Excel workbooks

This can be achieved  by using macros. Lets see how the first step can be done.

• Open the Excel Workbook, Press [ALT+F11] which will open Macro editor
• Under Insert tab, Click on Module
• Paste the below code in the Module window.
• Make sure the highlighted columns are edited as per your requirement.

"vcol " should be column number based on which the split will happen

"Set ws = Sheets("Sheet1")" is sheetname in which the data is available  

title = "A1:G1"  is the headings - my case it's 7 so G.

• Once the code edit is done , Press F5

Macro to be used

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

vcol = 1        

Set ws = Sheets("Sheet1")        

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

title = "A1:G1"           

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

For splitting the multiple sheets into separate Workbooks please refer here