Forum Discussion
Filter a range of cells with headers and data based on a criteria and construct a Table (VBA)
Try this:
Sub FilteredTable() Dim sw As Worksheet Dim tw As Worksheet Dim sr As Long Dim m As Long Dim sc As Long Dim n As Long Dim tr As Long Dim tc As Long Dim rg As Range Dim f As Boolean Application.ScreenUpdating = False Set sw = ActiveSheet m = sw.Range("B4").End(xlDown).Row n = sw.Range("C3").End(xlToRight).Column Set rg = sw.Range("O3").CurrentRegion Set tw = Worksheets.Add(After:=sw) tw.Range("B2").Value = "Product" tr = 2 For sr = 4 To m If Application.VLookup(sw.Cells(sr, 2).Value, rg, 2, False) = "True" Then tr = tr + 1 tw.Cells(tr, 2).Value = sw.Cells(sr, 2).Value tc = 2 For sc = 3 To n If Application.VLookup(sw.Cells(3, sc), rg, 2, False) = "True" Then tc = tc + 1 If Not f Then tw.Cells(2, tc).Value = sw.Cells(3, sc).Value If sc = n Then f = True End If End If sw.Cells(sr, sc).Copy Destination:=tw.Cells(tr, tc) End If Next sc End If Next sr tw.ListObjects.Add Source:=tw.Range("B2").CurrentRegion, XlListObjectHasHeaders:=xlYes Application.ScreenUpdating = True End Sub
May I ask you for a simple walkthrough on the logic behind it? It's only been few months since I am into the VBA world and, although I seem to understand the structure of the code, I miss some of it (mainly the lines where tr = 2, tr = tr +1, etc).
I would now need to rewrite it to fit a larger dataset and I would highly appreciate an explanation on exactly what needs to change in order to fit my actual and real data.
Thank you again for your support and efficient response. I really appreciate it.
Martin
Hi Martin,
The variables are used as follows:
Dim sw As Worksheet - source worksheet: the sheet with the data
Dim tw As Worksheet - target worksheet: the new sheet on which the table is created
Dim sr As Long - source row: row number on the source sheet
Dim m As Long - row number of the last data row on the source sheet
Dim sc As Long - source column: column number on the source sheet
Dim n As Long - column number of the last column on the source sheet
Dim tr As Long - target row: row number on the target sheet
Dim tc As Long - target column: column number on the target sheet
Dim rg As Range - the range that contains the categories plus the true/false values
Dim f As Boolean - a true/false variable that keeps track of whether we have filled the column headers on the target sheetThe code initialized the target row tr as 2.
The code loops through the rows of the source data and checks whether the product has True in the range on the right.
If so, it increments the target row by 1, to move to the next row to be written. If it's the first one (f is False), it checks the column headers to be used and writes them to row 2 of the target sheet.
It then loops through the cells in the current row of the source sheet and when appropriate, copies them to the target sheet.
At the end, the range on the target sheet is converted to a table.
Dear expert,
I am afraid I must ask for your advice again. I have been trying to fit the code into my actual, real data. The thing is that my original source table is on one sheet (SheetSource) and the list of headers with true/false conditions is on another sheet (SheetConditions). I have rearranged the code to fit that, but it gives me error 13 Type Mismatch. Is there something wrong with what I edited? I assumed it was possible to separate source data and conditions on different sheets. An additional note: True/False cells next to the headers are specifically named as desired. Changed, for instance, AB7 to "OrangeTrueorFalseValue". Could be the source error on the code?
Sub FilteredTable() Dim sw As Worksheet Dim tw As Worksheet Dim cw As Worksheet Dim sr As Long Dim m As Long Dim sc As Long Dim n As Long Dim tr As Long Dim tc As Long Dim rg As Range Dim f As Boolean Application.ScreenUpdating = False Set sw = ThisWorkbook.Sheets("SheetSource") Set cw = ThisWorkbook.Sheets("SheetConditions") m = sw.Range("C6").End(xlDown).Row n = sw.Range("D5").End(xlToRight).Column Set rg = cw.Range("AA7:AB108") Set tw = Worksheets.Add(After:=sw) tw.Range("B2").Value = "Product" tr = 2 For sr = 6 To m If Application.VLookup(sw.Cells(sr, 3).Value, rg, 2, False) = "True" Then tr = tr + 1 tw.Cells(tr, 2).Value = sw.Cells(sr, 3).Value tc = 2 For sc = 4 To n If Application.VLookup(sw.Cells(5, sc), rg, 2, False) = "True" Then tc = tc + 1 If Not f Then tw.Cells(2, tc).Value = sw.Cells(5, sc).Value If sc = n Then f = True End If End If sw.Cells(sr, sc).Copy Destination:=tw.Cells(tr, tc) End If Next sc End If Next sr tw.ListObjects.Add Source:=tw.Range("B2").CurrentRegion, XlListObjectHasHeaders:=xlYes Application.ScreenUpdating = True End SubI will highly appreciate this last help with this topic. Thank you so much in advance.
Martin
Please click Debug in the error message. Which line of the code is highlighted in yellow?
I have just happened to manage the issue!
The problem was that the code needs the list with all headers and true/false statement to be exactly ordered and named in the same way as the actuals rows and headers do from the original full table. Plus, (here is where I had the mistake) there cannot be any gaps between, for instance, two column headers in the original full table.
Thanks for your dedicated support.
- HansVogelaar
Thank you so much for your time. I am sure I can now follow the structure and apply this knowledge to future projects. I am sure your contributions are highly valuable and appreciated by the community.