Filtering different brands of items into new sheet

A

alvin97

New Member
Joined
Sep 26, 2024
Messages
23
Office Version
  1. 365
Platform
  1. Windows
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
1727343546089.png

After
1727343617999.png


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
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
alvin97 said:
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
View attachment 117335
After
View attachment 117337

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
Click to expand...
Try this:

Do you have more then two columns on the Main worksheet?

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

  ActiveWorkbook.Save
  
  Set Wb = ActiveWorkbook
  
  Q = Chr(34)
    
  Set WsMain = Wb.Sheets("Main")
  
  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, 2)
    
      arrBrands = Evaluate("SORT(UNIQUE(" & WsMain.Name & "!" & .Columns(1).Address & "),1)")
    
      For i = LBound(arrBrands) To UBound(arrBrands) - 1
            
        WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = "=FILTER(" & WsMain.Name & "!" & .Address & "," & WsMain.Name & "!" & .Columns(1).Address & "=" & Q & arrBrands(i, 1) & Q & ","""")"
     
      Next i
  
    End With
    
  End With
  
  With WsReport
    .UsedRange.Value = WsReport.UsedRange.Value
    .Cells.EntireColumn.AutoFit
  End With
  
End Sub
 
Upvote 0
HighAndWilder said:
Try this:

Do you have more then two columns on the Main worksheet?

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

  ActiveWorkbook.Save
 
  Set Wb = ActiveWorkbook
 
  Q = Chr(34)
   
  Set WsMain = Wb.Sheets("Main")
 
  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, 2)
   
      arrBrands = Evaluate("SORT(UNIQUE(" & WsMain.Name & "!" & .Columns(1).Address & "),1)")
   
      For i = LBound(arrBrands) To UBound(arrBrands) - 1
           
        WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = "=FILTER(" & WsMain.Name & "!" & .Address & "," & WsMain.Name & "!" & .Columns(1).Address & "=" & Q & arrBrands(i, 1) & Q & ","""")"
    
      Next i
 
    End With
   
  End With
 
  With WsReport
    .UsedRange.Value = WsReport.UsedRange.Value
    .Cells.EntireColumn.AutoFit
  End With
 
End Sub
Click to expand...
Yes, I do have more than 2 columns in my main worksheet (this 2 data was in column A & column M), as for report only need this 2 column information. thanks
 
Upvote 0
alvin97 said:
Yes, I do have more than 2 columns in my main worksheet (this 2 data was in column A & column M), as for report only need this 2 column information. thanks
Click to expand...
This code will take columns 1 and 13, A and M and use those for the report.

Are you able to use XL2BB Add-In to post code and example data next time. It helps developers considerably.

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")
    
  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, 13)
    
      arrBrands = Evaluate("SORT(UNIQUE(" & WsMain.Name & "!" & .Columns(1).Address & "),1)")
    
      For i = LBound(arrBrands) To UBound(arrBrands) - 1
      
        strFormula = "=CHOOSECOLS(FILTER(" & WsMain.Name & "!" & .Address & "," & WsMain.Name & "!" & .Columns(1).Address & "=" & Q & arrBrands(i, 1) & Q & ",""""),1,13)"
  
        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
  
End Sub
 
Upvote 0
HighAndWilder said:
Try this:

Do you have more then two columns on the Main worksheet?

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

  ActiveWorkbook.Save
 
  Set Wb = ActiveWorkbook
 
  Q = Chr(34)
   
  Set WsMain = Wb.Sheets("Main")
 
  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, 2)
   
      arrBrands = Evaluate("SORT(UNIQUE(" & WsMain.Name & "!" & .Columns(1).Address & "),1)")
   
      For i = LBound(arrBrands) To UBound(arrBrands) - 1
           
        WsReport.Range("A4").Offset(0, (i - 1) * 3).Formula2 = "=FILTER(" & WsMain.Name & "!" & .Address & "," & WsMain.Name & "!" & .Columns(1).Address & "=" & Q & arrBrands(i, 1) & Q & ","""")"
    
      Next i
 
    End With
   
  End With
 
  With WsReport
    .UsedRange.Value = WsReport.UsedRange.Value
    .Cells.EntireColumn.AutoFit
  End With
 
End Sub
Click to expand...
I have try your code, which this cause every single product on each column. Sorry i unable to show my main product info due to contain sensitive information.

This is a example of my product info.
sku: BrandA004
BrandA is my brand ID (unique)
004 is my product ID (not Unique)
Before.png
 
Upvote 0
alvin97 said:
I have try your code, which this cause every single product on each column. Sorry i unable to show my main product info due to contain sensitive information.

This is a example of my product info.
sku: BrandA004
BrandA is my brand ID (unique)
004 is my product ID (not Unique)
View attachment 117346
Click to expand...
So what do you want in the first column of each set of data on the Report sheet?

Do you want it to filter on the Alpha characters e.g. BrandB or the Numeric characters e.g. 001?
 
Upvote 0
HighAndWilder said:
So what do you want in the first column of each set of data on the Report sheet?

Do you want it to filter on the Alpha characters e.g. BrandB or the Numeric characters e.g. 001?
Click to expand...
This was what i want for the outcome
 
Upvote 0
HighAndWilder said:
So what do you want in the first column of each set of data on the Report sheet?

Do you want it to filter on the Alpha characters e.g. BrandB or the Numeric characters e.g. 001?
Click to expand...
yes filter on the Alpha characters BrandB. Thanks
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
501
ItalianPlatinum
I
G
  • Question Question
Workbook formulas copied with Sheet references in new Workbook
Replies
0
Views
389
GK039
G
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
799
Agnarr
Agnarr
A
  • Solved
why the code is slow despite of using advanced filter with simple data
2 3
Replies
23
Views
400
abdelfattah
A
I
  • Question Question
Find last row of sheet based off cell value to reference the sheet name
Replies
0
Views
455
ItalianPlatinum
I

Forum statistics

Threads
1,223,101
Messages
6,170,116
Members
452,302
Latest member
TaMere

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top