Creating separate files by using Advance filter

Dear Friends,
Hello....

PFA the file containing the data.

Is there any macro which creates separate files using advanced autofilter for the names mentioned in column BB of worksheet "Data".

The separate files should be saved where the main file is saved.

Generally I do it manually (filtering the data in column BB, copy and paste the data in separate file and the save as the file).
But its very time consuming.

Note:
Generally there are 20000 rows and 30 departments. In the attached file I have deleted the rows so that file size is acceptable.

Please help me.

File is protected

Kind regards
Leo

I have removed the password of file and re-attached it.

Very sorry for inconvenience.

See if this can do the job

Sub test()
Dim dic As Object, rng As Range, wks As Worksheet, mypath As String
Set dic = CreateObject("scripting.dictionary")
Set wks = Sheets("Data")
mypath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
With wks
    .Columns.Hidden = False
    For nrow = 7 To .Cells(Rows.Count, "BB").End(xlUp).Row - 1
        If (Not dic.exists(.Cells(nrow, "BB").Value)) Then
        dic.Add .Cells(nrow, "BB").Value, .Cells(nrow, "BB").Value
        Set rng = .Range("A6:BB" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=54, Criteria1:=.Range("BB" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveSheet.Columns.AutoFit
            ActiveWorkbook.SaveAs Filename:=mypath & .Range("BB" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
    .AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Kind regards
Leo

Leo,

Thanks a lot.
The macro is running fine.

Can I ask you for a favour?

Can I have the same features in the macro as the main file.
e.g
1. The data should be pasted from row 6 in the new file.
2. subtotal in L5.
3. formula "$L$5" in A5, O5,T5, V5, AV5, AW5, BB5.
4. Auto filter in row 6.
5. Freeze pane from G7.
6. Tab name should be "YTD A2 and A1"

7. files should be saved as "Cost dump YTD 1516 Jul 16 Operations"
where
A1 as "1516",
A2 as "Jul 16".
A3 as "Operation" (BB7, BU for File Prepare)


1 Question.
There may be empty rows in the data.
Will this macro pick up the data including empty rows.

Actually I am a beginner in excel.

Please help me.

Try with this modifications

Sub test()
Dim dic As Object, rng As Range, wks As Worksheet, mypath As String
Set dic = CreateObject("scripting.dictionary")
Set wks = Sheets("Data")
mypath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
With wks
    .Columns.Hidden = False
    For nrow = 7 To .Cells(Rows.Count, "BB").End(xlUp).Row - 1
        If (Not dic.exists(.Cells(nrow, "BB").Value)) Then
        dic.Add .Cells(nrow, "BB").Value, .Cells(nrow, "BB").Value
        Set rng = .Range("A6:BB" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=54, Criteria1:=.Range("BB" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            Range("A1", "A5").EntireRow.Insert
            lr = Range("A" & Rows.Count).End(xlUp).Row
            Range("L5") = Application.Sum(Range("L7", "L" & lr))
            Range("T5") = Application.Sum(Range("T7", "T" & lr))
            Range("V5") = Application.Sum(Range("V7", "V" & lr))
            Range("AV5") = Application.Sum(Range("AV7", "AV" & lr))
            Range("AW5") = Application.Sum(Range("AW7", "AW" & lr))
            ActiveSheet.Columns.AutoFit
            Rows("7:7").Select
            ActiveWindow.FreezePanes = True
            ActiveSheet.Name = "YTD " & wks.Range("A2") & " " & wks.Range("A1")
            ActiveWorkbook.SaveAs Filename:=mypath & "Cost Dump " & wks.Range("A1") & " " & wks.Range("A2") & " " & .Range("BB" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
    .AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Kind regards
Leo

Leo,

Thanks a lot.

You made my day. God bless you.

Leo,

Few more favours please.

1. Can I have the subtotal formula in L5. Currently, the L5 has value is no formula.
2. in A1, can i get the pop up window to enter the year ("Enter year in A1 : ") eg. 1516
3 in A2. can i get the pop up window to enter the Month ("Enter Month in A2") e.g Jul 16
4. in A3, can i get the pop up window to enter the Business Unit ("Enter BU in A3") eg. Operations

A1, A2, A3 will contain variable data

Rest everything is working fine.

Please help.

Also I need to make a pivot table in all the files.

Lalaarif,

i can not help with pivot, no experience with that
for the other points icluded file created bij code with a copy of the sheet for the desired result,
you make the sheet desired result like you want and send it back, then we all see what we can do.


Kind regards
Leo

Leo,

Your macro is perfectly working fine.

I am not able to attach the file.

But, Desired result are given below and should be same as the main file:
1. A1 = "1516".
2. A2 = "Jul 16"
3. A3 = "IT" ie. B7
4. A5 = "=$L$5" ie. subtotal amt.
5. L5 = "=SUBTOTAL(9,$L$6:$L$20000)"
6. AV5 = "=$L$5" ie. subtotal amt.

For saving the file, use cells A1, A2, A3 of the file.

Please assist.

I think of this

Sub test()
Dim dic As Object, rng As Range, wks As Worksheet, mypath As String
Set dic = CreateObject("scripting.dictionary")
Set wks = Sheets("Data")
mypath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
With wks
    .Columns.Hidden = False
    For nrow = 7 To .Cells(Rows.Count, "BB").End(xlUp).Row - 1
        If (Not dic.exists(.Cells(nrow, "BB").Value)) Then
        dic.Add .Cells(nrow, "BB").Value, .Cells(nrow, "BB").Value
        Set rng = .Range("A6:BB" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=54, Criteria1:=.Range("BB" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            Range("A1", "A5").EntireRow.Insert
            lr = Range("A" & Rows.Count).End(xlUp).Row
            Range("L1").FormulaR1C1 = "=sum(R6C:R20000C)"
            Range("L5").FormulaR1C1 = "=subtotal(9,R7C:R20000C)"
            Range("A5").FormulaR1C1 = "=R5C12"
            Range("T5").FormulaR1C1 = "=R5C12"
            Range("V5").FormulaR1C1 = "=R5C12"
            Range("AV5").FormulaR1C1 = "=R5C12"
            Range("AW5").FormulaR1C1 = "=R5C12"
            Range("A1").Resize(3) = Application.Transpose(Array(.Range("A1"), .Range("A2"), .Range("BB" & nrow)))
            ActiveSheet.Columns.AutoFit
            Rows("7:7").Select
            ActiveWindow.FreezePanes = True
            ActiveSheet.Name = "YTD " & wks.Range("A2") & " " & wks.Range("A1")
            ActiveWorkbook.SaveAs Filename:=mypath & "Cost Dump " & wks.Range("A1") & " " & wks.Range("A2") & " " & .Range("BB" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
    .AutoFilterMode = False
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

but without exemple of disired result it is stil a wild shot

Kind regards
Leo

Leo,

Thanks.

But there is a concern. The total of output file is not same as the main file. e.g Audit. Credit etc ....

Can you please have a look at it?

Please help.

I have 16 output files when i run code in this file, exact the number of unique values in column BB


Kind regards
Leo

Leo,

Files are generated correctly. Sorry about my wrong grammar and confusion. ("The total of output file is not same as the main file")

I meant was that the total in cell L5 of each file generated is not same as the auto-filtered total of main file.
e.g In the main file, filter on "audit" in column BB --> total is 2832335.
But, in the Audit file generated --> total is 2025553.

We are missing few rows in the new files.

Please help.

The red part is now on other place, tested and ok

Sub test()
Dim dic As Object, rng As Range, wks As Worksheet, mypath As String
Set dic = CreateObject("scripting.dictionary")
Set wks = Sheets("Data")
mypath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
With wks
    .Columns.Hidden = False
    For nrow = 7 To .Cells(Rows.Count, "BB").End(xlUp).Row - 1
        If (Not dic.exists(.Cells(nrow, "BB").Value)) Then
        dic.Add .Cells(nrow, "BB").Value, .Cells(nrow, "BB").Value
        Set rng = .Range("A6:BB" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=54, Criteria1:=.Range("BB" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            Range("A1", "A5").EntireRow.Insert
            lr = Range("A" & Rows.Count).End(xlUp).Row
            Range("L1").FormulaR1C1 = "=sum(R6C:R20000C)"
            Range("L5").FormulaR1C1 = "=subtotal(9,R7C:R20000C)"
            Range("A5").FormulaR1C1 = "=R5C12"
            Range("T5").FormulaR1C1 = "=R5C12"
            Range("V5").FormulaR1C1 = "=R5C12"
            Range("AV5").FormulaR1C1 = "=R5C12"
            Range("AW5").FormulaR1C1 = "=R5C12"
            Range("A1").Resize(3) = Application.Transpose(Array(.Range("A1"), .Range("A2"), .Range("BB" & nrow)))
            ActiveSheet.Columns.AutoFit
            Rows("7:7").Select
            ActiveWindow.FreezePanes = True
            ActiveSheet.Name = "YTD " & wks.Range("A2") & " " & wks.Range("A1")
            ActiveWorkbook.SaveAs Filename:=mypath & "Cost Dump " & wks.Range("A1") & " " & wks.Range("A2") & " " & .Range("BB" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    .AutoFilterMode = False
    Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Kind regards
Leo

Leo,

Thanks a lot.

Macro is working fine. God bless you

Leo,

1 question.

The macro you gave is working perfectly fine.

In addition to that, can we also create separate sheets in the new files generated based on months (column S) ?

Means there will be following sheets in the file.

1. YTD 1516 sheet
2. Separate month's sheets (col. S)

Please help.

All colomn S are Empty

Leo,
Very sorry for that.
Actually, I am not able to attach the file.

In col. S, can you please add Apr, May, Jun .... randomly and see if the macro can be run producing the desired output.

Please assist.

Leo,

Any luck ?

I am attaching the main file for your ref.
I have added the months in col. S.

Please help.

Lalaarif, maybe like this

Sub Splitfiles()
Dim dic As Object, rng As Range, rng2 As Range, wks As Worksheet, mypath As String, mystring As String
Set dic = CreateObject("scripting.dictionary")
Set wks = Sheets("Data")
mypath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
With wks
    .Columns.Hidden = False
    For nrow = 7 To .Cells(Rows.Count, "BB").End(xlUp).Row - 1
        If (Not dic.exists(.Cells(nrow, "BB").Value)) Then
            dic.Add .Cells(nrow, "BB").Value, .Cells(nrow, "BB").Value
            Set rng = .Range("A6:BB" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=54, Criteria1:=.Range("BB" & nrow).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            Range("A1", "A5").EntireRow.Insert
            lr = Range("A" & Rows.Count).End(xlUp).Row
            Range("L1").FormulaR1C1 = "=sum(R6C:R20000C)"
            Range("L5").FormulaR1C1 = "=subtotal(9,R7C:R20000C)"
            Range("A5").FormulaR1C1 = "=R5C12"
            Range("T5").FormulaR1C1 = "=R5C12"
            Range("V5").FormulaR1C1 = "=R5C12"
            Range("AV5").FormulaR1C1 = "=R5C12"
            Range("AW5").FormulaR1C1 = "=R5C12"
            Range("A1").Resize(3) = Application.Transpose(Array(.Range("A1"), .Range("A2"), .Range("BB" & nrow)))
            ActiveSheet.Columns.AutoFit
            Rows("6:6").AutoFilter
            Columns("L:L").NumberFormat = "_(* #,##0_);[Red]_(* (#,##0);_(* ""-""??_);_(@_)"
            Range("g7").Select
            ActiveWindow.FreezePanes = True
            Range("A2").NumberFormat = "mmm yy"
            Range("a5").NumberFormat = "_(* #,##0_);[Red]_(* (#,##0);_(* ""-""??_);_(@_)"
            ActiveWindow.Zoom = 85
            ActiveSheet.Name = "YTD " & wks.Range("A1")
            Set wks2 = Sheets("YTD " & wks.Range("A1"))
            lr2 = wks2.Cells(Rows.Count, "S").End(xlUp).Row
            mystring = ""
            For x = 7 To lr2
                r = InStr(1, mystring, wks2.Range("S" & x))
                If r = 0 Then
                    mystring = mystring & "|" & wks2.Range("S" & x)
                    wks2.Range("A1", "BB" & lr).AutoFilter field:=19, Criteria1:=wks2.Cells(x, "S")
                    wks2.Range("A1", "BB" & lr).SpecialCells(xlCellTypeVisible).Copy
                    Sheets.Add after:=Sheets(Sheets.Count)
                    ActiveSheet.Paste
                    Range("L1").FormulaR1C1 = "=sum(R6C:R20000C)"
                    Range("L5").FormulaR1C1 = "=subtotal(9,R7C:R20000C)"
                    Range("A5").FormulaR1C1 = "=R5C12"
                    Range("T5").FormulaR1C1 = "=R5C12"
                    Range("V5").FormulaR1C1 = "=R5C12"
                    Range("AV5").FormulaR1C1 = "=R5C12"
                    Range("AW5").FormulaR1C1 = "=R5C12"
                    Range("A1").Resize(3) = Application.Transpose(Array(.Range("A1"), wks2.Range("S" & x), .Range("BB" & nrow)))
                    Columns.AutoFit
                    Rows("6:6").AutoFilter
                    Columns("L:L").NumberFormat = "_(* #,##0_);[Red]_(* (#,##0);_(* ""-""??_);_(@_)"
                    Range("g7").Select
                    ActiveWindow.FreezePanes = True
                    Range("A2").NumberFormat = "mmm yy"
                    Range("A5").NumberFormat = "_(* #,##0_);[Red]_(* (#,##0);_(* ""-""??_);_(@_)"
                    ActiveWindow.Zoom = 85
                    ActiveSheet.Name = "YTD " & Format(Range("A2"), "mmm yy") & " " & wks.Range("A1")
                End If
            Next
            wks2.Range("A1", "BB" & lr2).AutoFilter field:=19
            ActiveWorkbook.SaveAs Filename:=mypath & "Cost Dump " & wks.Range("A1") & " " & wks.Range("A2") & " " & .Range("BB" & nrow).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    .AutoFilterMode = False
    Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "File Save As Completed"
End Sub

Cheers
Leo

Thanks a lot.

Macro is working fine.

1 more favour.
Currently, monthwise files (based on col. S) are generated in the new files.
Can we have the monthwise sheets in the main file itself also ?

Please assist.