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