Filtering different brands of items into new sheet

alvin97 · Sep 26, 2024

I needs help on with filter different brand of item, as current VBA code was all using range cell to filter into different column. This make a lot of code needed to amend when there is a new product. Is there a way to filter each brand with unique SKU like (BrandA, BrandB, BrandC)? Thanks

Before

After

VBA Code:

Sub Report()

Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Main"

Dim ResultCell As Range
Dim Sheet As Worksheet

Set Sheet = ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
Sheet.Name = "Report"

Sheets("Main").Range("$A$4:$A$21").Copy
Sheets("Report").Activate
Range("A4").Select
ActiveSheet.Paste

Sheets("Main").Range("$A$22:$A$35").Copy
Sheets("Report").Activate
Range("D4").Select
ActiveSheet.Paste

Sheets("Main").Range("$A$36:$A$45").Copy
Sheets("Report").Activate
Range("G4").Select
ActiveSheet.Paste


    Dim LookupValueCell As Range
    Dim LookupVector As Range
    Dim ResultVector As Range

    
    Set ResultCell = Sheets("Report").Range("$B$4:$B$21")
    Set LookupValueCell = Sheets("Report").Range("$A$4:$A$400")
    Set LookupVector = Sheets("Main").Range("$A$4:$A$400")
    Set ResultVector = Sheets("Main").Range("$B$4:$B$23")

ResultCell = WorksheetFunction.Lookup(LookupValueCell, LookupVector, ResultVector)

    Dim LookupValueCell1 As Range
    Dim LookupVector1 As Range
    Dim ResultVector1 As Range
    Dim ResultCell1 As Range
    
    
    Set ResultCell1 = Sheets("Report").Range("$E$4:$E$17")
    Set LookupValueCell1 = Sheets("Report").Range("$D$4:$D$400")
    Set LookupVector1 = Sheets("Main").Range("$A$4:$A$400")
    Set ResultVector1 = Sheets("Main").Range("$B$4:$B$372")

ResultCell1 = WorksheetFunction.Lookup(LookupValueCell1, LookupVector1, ResultVector1)

    Dim LookupValueCell2 As Range
    Dim LookupVector2 As Range
    Dim ResultVector2 As Range
    Dim ResultCell2 As Range
    
    
    Set ResultCell2 = Sheets("Report").Range("$H$4:$H$13")
    Set LookupValueCell2 = Sheets("Report").Range("$G$4:$H$400")
    Set LookupVector2 = Sheets("Main").Range("$A$4:$A$400")
    Set ResultVector2 = Sheets("Main").Range("$B$4:$B$372")

ResultCell2 = WorksheetFunction.Lookup(LookupValueCell2, LookupVector2, ResultVector2)
 
DateString = Format(Now, "DDMMMYYYY")
[B1].Value = DateString
End Sub

alvin97 · Sep 27, 2024

HighAndWilder said:

Use your data with the first row deleted and no blank rows.

Use this code. I used the data as in post 24.

VBA Code:

Public Sub subFilterBrands()
Dim arrBrands() As Variant
Dim i As Integer
Dim rngData As Range
Dim WsReport As Worksheet
Dim WsMain As Worksheet
Dim Wb As Workbook
Dim Q As String
Dim strFormula As String

  ActiveWorkbook.Save
 
  Set Wb = ActiveWorkbook
 
  Q = Chr(34)
   
  Set WsMain = Wb.Sheets("Main")
 
  WsMain.Activate
  
  strFormula = "=SUBSTITUTE($A2,TEXTJOIN(" & Q & Q & ",TRUE,IFERROR((MID($A2,ROW(INDIRECT(" & Q & "1:" & Q & "&LEN($A2))),1)*1)," & Q & Q & "))," & Q & Q & ",1)"
 
  WsMain.Range("B1").EntireColumn.Insert
 
  With WsMain.Range("A1").CurrentRegion.Columns(1)
 
    With .Offset(1, 1).Resize(.Rows.Count, 1)
      .Cells(1).Offset(-1, 0).Value = "Brand"
      .Formula2 = strFormula
      .Value = .Value
    End With
 
  End With
 
  Application.DisplayAlerts = False
  On Error Resume Next
  Wb.Worksheets("Report").Delete
  On Error GoTo 0
  Application.DisplayAlerts = True
 
  Set WsReport = ActiveWorkbook.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count))

  WsReport.Name = "Report"
 
  With WsMain.Range("A1").CurrentRegion
 
    With .Offset(1, 0).Resize(.Rows.Count, .Columns.Count)
      
      arrBrands = Evaluate("SORT(UNIQUE(" & WsMain.Name & "!" & .Columns(2).Address & "),1)")
   
      For i = LBound(arrBrands) To UBound(arrBrands) - 1
                 
        strFormula = "=CHOOSECOLS(FILTER(" & WsMain.Name & "!" & .Address & "," & WsMain.Name & "!" & .Columns(2).Address & "=" & Q & arrBrands(i, 1) & Q & ",""""),2,14)"
 
        WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula
   
      Next i
 
    End With
   
  End With
   
  With WsReport
    .UsedRange.Value = WsReport.UsedRange.Value
    .Cells.EntireColumn.AutoFit
  End With
   
  WsMain.Range("B1").EntireColumn.Delete
 
  MsgBox "Reports Compiled.", vbOKOnly, "Confirmation"
 
End Sub

Same error as #29, still limited to "brand"

HighAndWilder · Sep 27, 2024

alvin97 said:
Same error as #29, still limited to "brand"

Please post the Main sheet after the error has occurred.

alvin97 · Sep 27, 2024

Inventory_Products_Stock_Level_Report_testing.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

1

SKU

Brand

Unit extract from SKU

Product

Unit

Available

Allocated

Available

Allocated

Available

Allocated

Available

Allocated

Total

2

HTDKG107

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model1 - SeriesA / HTDKG107

$E$2

$F$2

$G$2

$H$2

$I$2

$J$2

914.00

$L$3

9.14

3

HTDKG108

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model1 - SeriesB / HTDKG108

$E$3

$F$3

$G$3

$H$3

$I$3

$J$3

900.00

$L$4

9

4

HTDKG109

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model1 - SeriesC / HTDKG109

$E$4

$F$4

$G$4

$H$4

$I$4

$J$4

1,170.00

$L$5

11.7

5

HTDKG110

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model1 - SeriesD / HTDKG110

$E$5

$F$5

$G$5

$H$5

$I$5

$J$5

490.00

$L$6

4.9

6

HTDKG111

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model1 - SeriesE / HTDKG111

$E$6

$F$6

$G$6

$H$6

$I$6

$J$6

1,500.00

$L$7

15

7

HTK001

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesF / HTK001

$E$7

$F$7

$G$7

$H$7

$I$7

$J$7

2,318.00

$L$8

23.18

8

HTK002

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesG / HTK002

$E$8

$F$8

$G$8

$H$8

$I$8

$J$8

1,518.00

$L$9

15.18

9

HTK003

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesH / HTK003

$E$9

$F$9

$G$9

$H$9

$I$9

$J$9

2,866.00

$L$10

28.66

10

HTK005

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesI / HTK005

$E$10

$F$10

$G$10

$H$10

$I$10

$J$10

240.00

$L$11

2.4

11

HTK006

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesJ / HTK006

$E$11

$F$11

$G$11

$H$11

$I$11

$J$11

2,318.00

$L$12

23.18

12

HTK014

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesK / HTK014

$E$12

$F$12

$G$12

$H$12

$I$12

$J$12

546.00

$L$13

5.46

13

HTK016

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model2 - SeriesL / HTK016

$E$13

$F$13

$G$13

$H$13

$I$13

$J$13

1,505.00

$L$14

15.05

15

HTDG01

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG01

$E$15

$F$15

$G$15

$H$15

$I$15

$J$15

2,198.00

$L$16

21.98

17

HTDG02

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG02

$E$17

$F$17

$G$17

$H$17

$I$17

$J$17

2,214.00

$L$18

22.14

19

HTDG03

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG03

$E$19

$F$19

$G$19

$H$19

$I$19

$J$19

1,850.00

$L$20

18.5

21

HTDG04

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG04

$E$21

$F$21

$G$21

$H$21

$I$21

$J$21

1,384.00

$L$22

13.84

23

HTDG05

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG05

$E$23

$F$23

$G$23

$H$23

$I$23

$J$23

740.00

$L$24

7.4

25

HTDG06

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG06

$E$25

$F$25

$G$25

$H$25

$I$25

$J$25

2,338.00

$L$26

23.38

27

HTDG07

=SUBSTITUTE($A2,TEXTJOIN("",TRUE,IFERROR((MID($A2,ROW(INDIRECT("1:"&LEN($A2))),1)*1),"")),"",1)

Model3 / HTDG07

$E$27

$F$27

$G$27

$H$27

$I$27

$J$27

1,980.00

$L$28

19.8

Main

Cell Formulas
Range	Formula
N2:N13,N15,N17,N19,N21,N23,N25,N27	N2	=$L2/100

HighAndWilder · Sep 27, 2024

alvin97 said:
I have tried delete the first row, but there is 1004 error on this code "WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula = False". After i change my HTDKG, HTK and HTDG to BrandA, BrandB, and BrandC, the report came working correctly.
So is there a way to filter from "Brand" change to my sku code?

Where is this line in the code?

WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula = False

alvin97 · Sep 27, 2024

HighAndWilder said:
Where is this line in the code?

WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula = False

This was the line WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula, when roll over shown this. WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = strFormula = False

Fuji · Sep 28, 2024

See if this works as you want.

Code:

Sub test()
    Dim x, e, t&
    If Not [isref('result'!a1)] Then Sheets.Add.Name = "Result"
    Sheets("result").Cells.Clear: t = 1
    With Sheets("main").[a1].CurrentRegion.Resize(, 2).offset(1)
        x = .Parent.[unique(iferror(textbefore(a3:a20000,sequence(10,,0),,,1),""))]
        For Each e In x
            If e <> "" Then
                .AutoFilter 1, e & "*"
                .Offset(1).Copy Sheets("result").Cells(4, t)
                t = t + 3
            End If
        Next
    End With
End Sub

alvin97 · Sep 28, 2024

Fuji said:

See if this works as you want.

Code:

Sub test()
    Dim x, e, t&
    If Not [isref('result'!a1)] Then Sheets.Add.Name = "Result"
    Sheets("result").Cells.Clear: t = 1
    With Sheets("main").[a1].CurrentRegion.Resize(, 2).offset(1)
        x = .Parent.[unique(iferror(textbefore(a3:a20000,sequence(10,,0),,,1),""))]
        For Each e In x
            If e <> "" Then
                .AutoFilter 1, e & "*"
                .Offset(1).Copy Sheets("result").Cells(4, t)
                t = t + 3
            End If
        Next
    End With
End Sub

Yes, the outcome layout is what i wanted, but the second data taken was on column B instead of column M.
And is there a way to remain the data on the main sheet as well? Thanks

Inventory_Products_Stock_Level_Report_testing.xlsm

A

B

C

D

E

F

G

H

I

1

2

3

4

HTDKG108

HTK001

HTDG01

5

HTDKG109

HTK002

HTDG02

6

HTDKG110

HTK003

HTDG03

7

HTDKG111

HTK005

HTDG04

8

HTK006

HTDG05

9

HTK014

HTDG06

10

HTK016

HTDG07

11

HTDG08

12

HTDG09

13

HTDG10

14

HTDG11

15

HTDG12

16

17

18

Result

Fuji · Sep 28, 2024

Like this?

Code:

Sub test()
    Dim x, e, t&
    If Not [isref('result'!a1)] Then Sheets.Add.Name = "Result"
    Sheets("result").Cells.Clear: t = 1
    With Sheets("main").[a1].CurrentRegion.Offset(1)
        x = .Parent.[unique(iferror(textbefore(a3:a20000,sequence(10,,0),,,1),""))]
        For Each e In x
            If e <> "" Then
                .AutoFilter 1, e & "*"
                With .Offset(1)
                    Union(.Columns("a"), .Columns("m")).Copy Sheets("result").Cells(4, t)
                End With
                t = t + 3
            End If
        Next
        .AutoFilter
    End With
End Sub

Edit;

And is there a way to remain the data on the main sheet as well?

alvin97 · Sep 28, 2024

Fuji said:

Like this?

Code:

Sub test()
    Dim x, e, t&
    If Not [isref('result'!a1)] Then Sheets.Add.Name = "Result"
    Sheets("result").Cells.Clear: t = 1
    With Sheets("main").[a1].CurrentRegion.Offset(1)
        x = .Parent.[unique(iferror(textbefore(a3:a20000,sequence(10,,0),,,1),""))]
        For Each e In x
            If e <> "" Then
                .AutoFilter 1, e & "*"
                With .Offset(1)
                    Union(.Columns("a"), .Columns("m")).Copy Sheets("result").Cells(4, t)
                End With
                t = t + 3
            End If
        Next
    End With
End Sub

Yes, this i was what i wanted Thank you.
This was before i run your code (Is there a way to remain this primary data in the main sheets?)



SKU	Unit extract from SKU	Product	Unit	Available	Allocated	Available	Allocated	Available	Allocated	Available	Allocated	Total
HTDKG107		Model1 - SeriesA / HTDKG107		$E$2	$F$2	$G$2	$H$2	$I$2	$J$2	914.00	$L$3	9.14
HTDKG108		Model1 - SeriesB / HTDKG108		$E$3	$F$3	$G$3	$H$3	$I$3	$J$3	900.00	$L$4	9
HTDKG109		Model1 - SeriesC / HTDKG109		$E$4	$F$4	$G$4	$H$4	$I$4	$J$4	1,170.00	$L$5	11.7
HTDKG110		Model1 - SeriesD / HTDKG110		$E$5	$F$5	$G$5	$H$5	$I$5	$J$5	490.00	$L$6	4.9
HTDKG111		Model1 - SeriesE / HTDKG111		$E$6	$F$6	$G$6	$H$6	$I$6	$J$6	1,500.00	$L$7	15
HTK001		Model2 - SeriesF / HTK001		$E$7	$F$7	$G$7	$H$7	$I$7	$J$7	2,318.00	$L$8	23.18
HTK002		Model2 - SeriesG / HTK002		$E$8	$F$8	$G$8	$H$8	$I$8	$J$8	1,518.00	$L$9	15.18
HTK003		Model2 - SeriesH / HTK003		$E$9	$F$9	$G$9	$H$9	$I$9	$J$9	2,866.00	$L$10	28.66
HTK005		Model2 - SeriesI / HTK005		$E$10	$F$10	$G$10	$H$10	$I$10	$J$10	240.00	$L$11	2.4
HTK006		Model2 - SeriesJ / HTK006		$E$11	$F$11	$G$11	$H$11	$I$11	$J$11	2,318.00	$L$12	23.18
HTK014		Model2 - SeriesK / HTK014		$E$12	$F$12	$G$12	$H$12	$I$12	$J$12	546.00	$L$13	5.46
HTK016		Model2 - SeriesL / HTK016		$E$13	$F$13	$G$13	$H$13	$I$13	$J$13	1,505.00	$L$14	15.05

HTDG01		Model3 / HTDG01		$E$15	$F$15	$G$15	$H$15	$I$15	$J$15	2,198.00	$L$16	21.98

HTDG02		Model3 / HTDG02		$E$17	$F$17	$G$17	$H$17	$I$17	$J$17	2,214.00	$L$18	22.14

HTDG03		Model3 / HTDG03		$E$19	$F$19	$G$19	$H$19	$I$19	$J$19	1,850.00	$L$20	18.5

HTDG04		Model3 / HTDG04		$E$21	$F$21	$G$21	$H$21	$I$21	$J$21	1,384.00	$L$22	13.84

HTDG05		Model3 / HTDG05		$E$23	$F$23	$G$23	$H$23	$I$23	$J$23	740.00	$L$24	7.4

HTDG06		Model3 / HTDG06		$E$25	$F$25	$G$25	$H$25	$I$25	$J$25	2,338.00	$L$26	23.38

This is after i run your code



SKU	Unit extract from SKU	Product	Unit	Available	Allocated	Available	Allocated	Available	Allocated	Available	Allocated	Total

















































Grand Total				0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00

Fuji · Sep 28, 2024

So, you don't want to change hide/unhide any row(s) in Main sheet...
try this one then.

Code:

Sub test()
    Dim e, w, x, y, t&
    If Not [isref('result'!a1)] Then Sheets.Add.Name = "Result"
    Sheets("result").Cells.Clear: t = 1
    With Sheets("main").[a1].CurrentRegion.Offset(1)
        x = .Parent.[unique(iferror(textbefore(a3:a20000,sequence(10,,0),,,1),""))]
        For Each e In x
            If (e <> "") * (LCase$(e) <> "grand total") Then
                y = Filter(.Parent.Evaluate("transpose(if(left(" & .Columns(1).Address & _
                ",len(""" & e & """))=""" & e & """,row(1:" & .Rows.Count & ")))"), False, 0)
                w = Application.Index(.Value, Application.Transpose(y), [{1,13}])
                Sheets("result").Cells(4, t).Resize(UBound(y) + 1, 2) = w
                t = t + 3
            End If
        Next
        .AutoFilter
    End With
End Sub

Filtering different brands of items into new sheet

alvin97

New Member

alvin97

New Member

Excel Facts

HighAndWilder

Well-known Member

alvin97

New Member

HighAndWilder

Well-known Member

alvin97

New Member

Fuji

Active Member

alvin97

New Member

Fuji

Active Member

alvin97

New Member

Fuji

Active Member

Similar threads

Forum statistics

Share this page

Filtering different brands of items into new sheet

New Member

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

Active Member

New Member

Active Member

New Member

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock