Vba to Auto filter based on multiple columns

149 Views Asked by At

I'm working on a project and I need your help

I need Vba code to Auto filter and count items based on multiple columns

For example I have

enter image description here

So the result should be

enter image description here

And so on for all the range

I tried Auto filter then select case code for the filltered data And worked but only for another view not the one I'm looking for And the resulted from select case was as below

enter image description here

Appreciate your support please to get the filtered data as this mode

enter image description here

1

There are 1 best solutions below

4
karma On BEST ANSWER

Since your expected result is confusing (if compare with the data in your picture), I an not so sure what kind of result that you expected.

Anyway, below is a lazy code which create a pivot table based on the data which looks like the one in your picture. After that, it's just a copy paste process.

It assumes that your data is in sheet1,
starts from cell A1 with six column header (cell A1 to F1),
and there's nothing at all to the left after column F.

Sub test()
Set sh = Sheets("Sheet1")
Set shResult = Sheets("Sheet2")
sh.Range("G:Z").Delete

With sh
Range("C1").Value = "BLANK"
Set rg = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
rg.Offset(0, 6).Value = 1
rg.Resize(rg.Rows.Count, 7).Name = "data"
End With

    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "data", Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:=sh.Range("P1"), TableName:="ptTmp", DefaultVersion _
        :=xlPivotTableVersion14
        
    With sh.PivotTables("ptTmp").PivotFields("SKU Name")
        .Orientation = xlRowField
        .Position = 1
        .Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    
    With sh.PivotTables("ptTmp").PivotFields("Supplier")
        .Orientation = xlRowField
        .Position = 2
        .Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    
    With sh.PivotTables("ptTmp").PivotFields("Inventory Item Status")
        .Orientation = xlRowField
        .Position = 3
        .Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    
    With sh.PivotTables("ptTmp").PivotFields("Flag")
        .Orientation = xlRowField
        .Position = 4
        .Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    End With
    
    With sh.PivotTables("ptTmp").PivotFields("FLAG")
        .PivotItems("Used").Visible = False
        .PivotItems("Bad").Visible = False
    End With
    
    With sh.PivotTables("ptTmp")
    .AddDataField ActiveSheet.PivotTables("ptTmp"). _
        PivotFields("1"), "COUNT", xlCount
    .RowAxisLayout xlTabularRow
    .RepeatAllLabels xlRepeatLabels
    .ColumnGrand = False
    .ShowTableStyleRowHeaders = False
    .TableRange1.Copy
    End With

    shResult.Range("A1").PasteSpecial Paste:=xlPasteValues
    shResult.Range("A1").PasteSpecial Paste:=xlPasteFormats
    
        With sh.PivotTables("ptTmp")
            With .PivotFields("FLAG")
            .ClearAllFilters
            .PivotItems("New").Visible = False
            .PivotItems("Bad").Visible = False
            End With
            With .PivotFields("SKU Name")
            Range(.DataRange, .DataRange.Offset(0, 4)).Copy
            End With
        End With
    
    shResult.Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial Paste:=xlPasteValues
    
        With sh.PivotTables("ptTmp")
            With .PivotFields("FLAG")
            .ClearAllFilters
            .PivotItems("New").Visible = False
            .PivotItems("Used").Visible = False
            End With
            With .PivotFields("SKU Name")
            Range(.DataRange, .DataRange.Offset(0, 4)).Copy
            End With
        End With

    shResult.Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial Paste:=xlPasteValues
    
    sh.Range("G:Z").Delete
    shResult.Activate
    shResult.Range("A1").Select
End Sub

enter image description here