Split Workbook In To Multiple Files Using Advanced Filter And Unique Values

[rajasekhar]

Hi,

i have a code which creates individual workbooks using advance filter for one tab ..but i am having another tab same action is to be repeated but both sheets should be placed in one workbook cost center wise.

My code is as follows for LOAD DATA (Tab).

Sub DistributeRows()
    Dim wbNew As Workbook
    Dim wsData As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim rngCrit As Range
    Dim LastRow As Long
     
    Set wsData = Worksheets("LOAD DATA")
    Set wsCrit = Worksheets.Add
     
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
     
    wsData.Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
     
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wsNew = Worksheets.Add
        wsData.Range("A1:AH" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True
        wsNew.Name = rngCrit
        wsNew.Copy
        Set wbNew = ActiveWorkbook
        wbNew.SaveAs ThisWorkbook.Path & "\" & rngCrit & "-" & Format(Date, "dd mmm yy")
        wbNew.Close SaveChanges:=True
        Application.DisplayAlerts = False
        wsNew.Delete
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
     
    wsCrit.Delete
    Application.DisplayAlerts = True
End Sub

Need your help to replicate the same for Trans detail tab as well..

Trans Detail data starts from A95, and I need columns till R

Thanks alot for your help.

Regards,
Raj

[Excel Fox]

Try this....

Sub DistributeRows()

    Dim wbNew As Workbook
    Dim wsData As Worksheet
    Dim wksTransDet As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim rngCrit As Range
    Dim LastRow As Long
     
    Set wsData = Worksheets("LOAD DATA")
    Set wksTransDet = Worksheets("Trans Detail")
    Set wsCrit = Worksheets.Add
    LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
    wsData.Range("A1:A" & LastRow - 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
     
    Set rngCrit = wsCrit.Range("A2")
    While rngCrit.Value <> ""
        Set wbNew = Workbooks.Add(xlWorksheet)
        wbNew.Sheets.Add
        wsData.Range("A1:AH" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wbNew.Sheets(1).Range("A1"), Unique:=True
        wksTransDet.Range("A95:R" & wksTransDet.Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wbNew.Sheets(2).Range("A1"), Unique:=True
        With wbNew
            .Sheets(1).Name = rngCrit
            .Sheets(2).Name = rngCrit & "-2"
            .SaveAs ThisWorkbook.Path & "\" & rngCrit & "-" & Format(Date, "dd mmm yy")
            .Close SaveChanges:=True
        End With
        rngCrit.EntireRow.Delete
        Set rngCrit = wsCrit.Range("A2")
    Wend
    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True
    Set wbNew = Nothing
    Set wksTransDet = Nothing
    Set wsData = Nothing
    
End Sub

[rajasekhar]

Hi,

Thanks alot for your Outstanding support and help with in short span of time.

would like to thank you for all your efforts and knowledge sharing part.

Thanks & Regards,
Raj