SOLVED

Filter a range of cells with headers and data based on a criteria and construct a Table (VBA)

Brass Contributor

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 & CriteriaFull Table & CriteriaExpected OutcomeExpected Outcome

 

Thank you so much in advance for your kind help.

 

Martin

12 Replies

@MAngosto 

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,3

ActiveCell.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.
best response confirmed by MAngosto (Brass Contributor)
Solution

@MAngosto 

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
@Hans Vogelaar

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.

Martin

@MAngosto 

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 sheet

The 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.

purely VBA version of it?

Yes,this is pure vba.

Have you run it?
@Hans Vogelaar

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.

@Hans Vogelaar 

 

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 Sub

 

I will highly appreciate this last help with this topic. Thank you so much in advance.

 

Martin

@MAngosto 

Please click Debug in the error message. Which line of the code is highlighted in yellow?

@Hans Vogelaar 

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.

 

1 best response

Accepted Solutions
best response confirmed by MAngosto (Brass Contributor)
Solution

@MAngosto 

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

View solution in original post