VBA, filtering, formatting and saving various formatted versions to individual files

[Gti182]

Hi All,

I'm looking to automate a recurring monthly task.

Process:
1) Filter original data (tab 1) by colour Column "D" then priority Column "C". Reds first then Amber then Green with colours to be individually ranked by project priority 1's first then 2's, 3, 4, 5 etc.

I've added a filtered data tab (tab 2) to show how the filtered result should look.

2) I then need to save down 6 individual copies of this data filtered by department Column "B". The filename should be called the department name and should only contain that particular departments information.

To illustrate i've filtered by the "Operations" department in the 3rd tab. I'd then need to save down this tab only to a new file called "Operations.xlsm"

Hope this makes sense.

I can do this manually simply enough but going forward there will be many more entries and more departments making it quite time consuming.

Regards
Neill

[Gti182]

i've used this code to filter the data by colour and priority but having trouble coding the filtered department data to save to a new file.

Sub Filter()
'
' Filter by colour then by priority
'

    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort.SortFields _
        .Clear
    ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort.SortFields _
        .Add(Range("D3:D18"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 0, 0)
    ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort.SortFields _
        .Add(Range("D3:D18"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(255, 192, 0)
    ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort.SortFields _
        .Add(Range("D3:D18"), xlSortOnCellColor, xlAscending, , xlSortNormal). _
        SortOnValue.Color = RGB(0, 176, 80)
    ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort.SortFields _
        .Add Key:=Range("C3:c18"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Consolidated Poject RAG").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[jaslake]

Hi Gti182

This Code is in the attached and appears to do as you require

Option Explicit
Sub Do_Stuff()
    Dim wb As Workbook
    Dim newBook As Workbook
    Dim ws As Worksheet
    Dim LR As Long
    Dim cel As Range
    Dim myPath As String

    myPath = ThisWorkbook.Path & "\"

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Original")

    Application.ScreenUpdating = False
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If

    With ws
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add(Range("D2:D" & LR), _
                xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
        .Sort.SortFields.Add(Range("D2:D" & LR), _
                xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 176, 80)
        .Sort.SortFields.Add Key:=Range("C2:C" & LR), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A2:D" & LR)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Columns(2).Copy Sheets("Lists").Range("A1")
        Sheets("Lists").Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
        ActiveWorkbook.Names.Add Name:="Depts", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"

        For Each cel In Range("Depts")
            .Range("A1:D" & LR).AutoFilter Field:=2, Criteria1:=cel

            Set newBook = Workbooks.Add(xlWBATWorksheet)

            With newBook
                With ws.Range("A1:D" & LR)
                    .Copy
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
                    newBook.Sheets(1).Name = cel
                End With

                Application.DisplayAlerts = False
                .SaveAs myPath & cel, FileFormat:=51
                Application.DisplayAlerts = True
                .Close False
            End With
        Next cel
        .AutoFilterMode = False
        Application.DisplayAlerts = False
        Sheets("Lists").Delete
        Application.DisplayAlerts = True
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[Gti182]

That's! That works amazingly! Really appreciate it!

[Gti182]

Hi John,

dropped you a message. If i add an additional row to the top of the "original" tab how would this affect the code?

Regards
Neill

[jaslake]

Hi Gti182

If i add an additional row to the top of the "original" tab how would this affect the code

It depends on how the new Row is populated and/or formated...show me.

[jaslake]

Hi Gti182

The attached workbook dumps the Mergerd Cells and uses Center Across Selection in it's place.
Let me know of issues.

Option Explicit
Sub Do_Stuff()
    Dim wb As Workbook
    Dim newBook As Workbook
    Dim ws As Worksheet
    Dim LR As Long
    Dim cel As Range
    Dim myPath As String

    myPath = ThisWorkbook.Path & "\"

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Original")

    Application.ScreenUpdating = False
    If Not Evaluate("ISREF(Lists!A1)") Then
        Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
    Else
        Sheets("Lists").Cells.Clear
    End If

    With ws
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add(Range("D3:D" & LR), _
                xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
        .Sort.SortFields.Add(Range("D3:D" & LR), _
                xlSortOnCellColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(0, 176, 80)
        .Sort.SortFields.Add Key:=Range("C3:C" & LR), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A3:D" & LR)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        .Columns(2).Copy Sheets("Lists").Range("A1")
        Sheets("Lists").Columns("A:A").RemoveDuplicates Columns:=1, Header:=xlYes
        ActiveWorkbook.Names.Add Name:="Depts", RefersTo:= _
                "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"

        For Each cel In Range("Depts")
            .Range("A3:D" & LR).AutoFilter Field:=2, Criteria1:=cel

            Set newBook = Workbooks.Add(xlWBATWorksheet)

            With newBook
                With ws.Range("A1:D" & LR)
                    .Copy
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
                    newBook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll
                    newBook.Sheets(1).Name = cel
                End With

                Application.DisplayAlerts = False
                .SaveAs myPath & cel, FileFormat:=51
                Application.DisplayAlerts = True
                .Close False
            End With
        Next cel
        .AutoFilterMode = False
        Application.DisplayAlerts = False
        Sheets("Lists").Delete
        Application.DisplayAlerts = True
    End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[Gti182]

The extra row added to the top of the sheet is formatted as text. In the new row A1-C1 will be a merged cell called "Project information"

[jaslake]

Hi Gti182

This is what I was concerned about

In the new row A1-C1 will be a merged cell called "Project information"

Show me the new file and I'll play with it...merged cells cause nothing but frustration...we'll see what we can do.

[Gti182]

Thanks John that works beautifully. I've tested it with and without merged cells and they both work with above code. thanks again!

[jaslake]

You're welcome...glad I could help. Thanks for the Rep.