Forum Discussion
Filter a range of cells with headers and data based on a criteria and construct a Table (VBA)
Hello experts,
I am running Microsoft® Excel® for Microsoft 365 on Windows 10. Please kindly refer to the sample images attached below for a better understanding of the context. The first sheet displays my actual setting, and the second one shows the expected outcome.
I currently have a range of cells simulating an actual "Table" from Excel objects. It is simply a range of cells where column and row headers can be found, as well as inside data values. It simulates fruit imports for different countries, where column headers are the labeled countries and row headers are the type of fruit these are importing. The inside data values are just quantities.
On the other hand, I have a vertical list with all headers (column and row headers, both included), with an adjacent cell indicating the condition "true" or "false" for each of them. These criteria will dictate whether that specific header will be considered or not when constructing the filtered Table.
The goal is to generate on a newly created sheet an actual Excel Table that only displays the information of those rows and columns that had the value "True" in the list of conditions. That is, only populate the filtered table with those headers marked as "True", as well as their corresponding inside values.
A couple of additional notes:
- The format of the "original full table" as well as the list of conditions cannot be changed. In reality, it is a large range of cells with a lot of columns and headers, and the list of conditions is formatted in that way purposefully.
- The inside data points (in my example, quantities of imported fruit) of my original full table do have different text formats. Some may be expressed as currencies, others as simple numbers. Ideally, the filtered table should contain the same format for each data point, but I could also do it if they all remain as numbers if the latter is not possible.
I have been trying for several days to run an efficient code for this, but I was not even close to getting it. Need fresh ideas.
Images for context:
Full Table & CriteriaExpected Outcome
Thank you so much in advance for your kind help.
Martin
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
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- HansVogelaar
Thank you for your kind support! It actually worked excellently!
May I ask you for a simple walkthrough on the logic behind it? It's only been a few months since I entered 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 of 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 - Thank you for your kind support! It actually worked excellently!
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.
MartinHi 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.
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;';Data Source=" & ThisWorkbook.FullName
sql="select * from [Sheet1$]"
fields="Product," & "Spain,Italy"
'here use function textjoin to get fields and products true e.g. Spain,Italy and Apple,Orange ;the source sheet data starts at range a1
criteria=" where instr(""Apple,Orange"",Product)>0"
sql="select " & fields & " from [Sheet1$]" & criteria
Set Rst=CreateObject("ADODB.Recordset")Rst.CursorLocation = 3
Rst.open sql,conn,adOpenKeyset,3ActiveCell.CopyFromRecordset Rst
- Hello!
Thank you for your kind reply. I do not doubt it could be useful.
Unfortunately, I am not familiarized with ADO at all, and I am afraid I will not even get to understand your code. Do you have, by any chance, a purely VBA version of it?
Thanks again.- purely VBA version of it?
Yes,this is pure vba.
Have you run it?
