Split Excel worksheet into multiple worksheets based on a column with VBA

Question

I have the following data:

Data in sheet 1 :

Name    Fund Source Remark  Approved (Y/N)
Alice   C&C Ok  Y
John    C&C Ok  N

Data in sheet 2 :

 Sr No   Name   Category     Requirement - A     Requirement - B     Requirement - C     Requirement - D    Eligibility Remarks
1   Alice   A+  3   2   0   0   Ok  

Data in sheet 3 :

 Month  Delivery     Support Pay    Client Name  Remark     Mfg Year    Model Year  Remarks
Jan Cash     269    Alice       2022    2022    

Question is simple and may be repetitive.

1. I have an Excel workbook which contains 3 sheets

2. I have a criteria column which should be applied to all 3 sheets for splitting this workbook into mulitple workbooks

I am looking for a macro which enables me to create multiple Excel workbooks based on the column Name like:

• Excel/CSV for all Names like Alice, John

The only challenge I am facing here is

1. The header on which the filter criteria should be applied to is different in sheet 3 (In sheet 1 and 2 the header is Client but in sheet 3 it is named as client name)

The final workbook should contain 3 sheets but should only show name of one individual (For example, 2 different workbooks will be created here one for Alice and one for John)

I have tried coding in VBA but was only able to filter one sheet. Can someone help me with a macro which would help in generating multiple workbooks based on the above details?

Here is the code :

Sub Splitdatabycol()
    
    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
    Dim xTRg As Range
    Dim xVRg As Range
    Dim xWSTRg As Worksheet
    Dim xWS As Worksheet
    
    On Error Resume Next
    
    Set xTRg = Application.InputBox("Please select the header rows:", "Prompt", "", Type:=8)
    If TypeName(xTRg) = "Nothing" Then Exit Sub
    
    Set xVRg = Application.InputBox("Please select the column you want to split data based on:", "Prompt", "", Type:=8)
    If TypeName(xVRg) = "Nothing" Then Exit Sub
    
    vcol = xVRg.Column
    Set ws = xTRg.Worksheet
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = xTRg.AddressLocal
    titlerow = xTRg.Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"
    
    Application.DisplayAlerts = False
    
    If Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
    Else
        Sheets("xTRgWs_Sheet").Delete
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"
    End If
    
    Set xWSTRg = Sheets("xTRgWs_Sheet")
    xTRg.Copy
    xWSTRg.Paste Destination:=xWSTRg.Range("A1")
    ws.Activate
    
    For i = (titlerow + xTRg.Rows.Count) 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
            Set xWS = Sheets.Add(after:=Worksheets(Worksheets.Count))
            xWS.Name = myarr(i) & ""
        Else
            xWS.Move after:=Worksheets(Worksheets.Count)
        End If
        xWSTRg.Range(title).Copy
        xWS.Paste Destination:=xWS.Range("A1")
        ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy xWS.Range("A" & (titlerow + xTRg.Rows.Count))
        Sheets(myarr(i) & "").Columns.AutoFit
    Next
    
    xWSTRg.Delete
    ws.AutoFilterMode = False
    ws.Activate
    Application.DisplayAlerts = True

End Sub

Answer 1

I think an advanced filter might work well for this scenario:

Sub newWorkbookPerName()
      
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, splitWb As Workbook
    Dim ws1EndColumn As Long, ws2EndColumn As Long, ws3EndColumn As Long
    Dim ws1Name As Long, ws2Name As Long, ws3Name As Long
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Set ws3 = ThisWorkbook.Worksheets("Sheet3")
    
    If ws1.Range("A2").Value2 <> "" Then
        ws1EndColumn = ws1.Range("A1").End(xlToRight).Column
        ws2EndColumn = ws2.Range("A1").End(xlToRight).Column
        ws3EndColumn = ws3.Range("A1").End(xlToRight).Column
    
        'Use AdvancedFilter to filter and copy data - https://excelmacromastery.com/vba-advanced-filter/
        'use match to find Name column
        ws1Name = Application.WorksheetFunction.Match("Name", ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)), 0)
        ws2Name = Application.WorksheetFunction.Match("Name", ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws1EndColumn)), 0)
        ws3Name = Application.WorksheetFunction.Match("*Name", ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws1EndColumn)), 0)
        'Put together criteria range for AdvanceFilter
        ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)).Offset(0, ws1EndColumn + 5).Value2 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, ws1EndColumn)).Value2
        ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws2EndColumn)).Offset(0, ws2EndColumn + 5).Value2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(1, ws2EndColumn)).Value2
        ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws3EndColumn)).Offset(0, ws3EndColumn + 5).Value2 = ws3.Range(ws3.Cells(1, 1), ws3.Cells(1, ws3EndColumn)).Value2
        For Each Name In ws1.Range("A2", ws1.Range("A1").End(xlDown))
            Workbooks.Add
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Name & ".xlsx"
            Set splitWb = ActiveWorkbook
            'Sheet1
            ws1.Cells(2, ws1Name).Offset(0, ws1EndColumn + 5).Value2 = Name
            ws1.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws1.Cells(1, ws1EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet1").Range("A1")
            'Sheet2
            splitWb.Sheets.Add after:=splitWb.Worksheets(splitWb.Worksheets.Count)
            ws2.Cells(2, ws2Name).Offset(0, ws2EndColumn + 5).Value2 = Name
            ws2.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws2.Cells(1, ws2EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet2").Range("A1")
            'Sheet3
            splitWb.Sheets.Add after:=splitWb.Worksheets(splitWb.Worksheets.Count)
            ws3.Cells(2, ws3Name).Offset(0, ws3EndColumn + 5).Value2 = Name
            ws3.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, ws3.Cells(1, ws3EndColumn + 6).CurrentRegion, splitWb.Worksheets("Sheet3").Range("A1")
            splitWb.Close SaveChanges:=True
        Next
    End If

End Sub