I have 3 tables, 1 table in every sheet (Sheet1-Sheet3). All three tables have the same number of columns and the same names (in order: Region | Category | Product | Price). Next, the three tables will be filtered according to the criteria that have been created and copy them into one table on another sheet by clicking the button (Sheet4). I have no problem if the displayed / copied data matches the source table (displays the entire table column) like the result in Sheet5. Here's the image and code:
The problem is, the source table that will be used later are not the same (as shown in the following figure). With the same filter criteria, I didn't get the right results. Can I be helped to fix it? I am open to other solutions. Thank you.
VBA Code:
Sub CopyFilteredTables()
Dim WS As Worksheet
Dim lobTable As ListObject
Dim fltrs As Range
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set fltrs = Selection ' Make a selection for the filter criteria.
ReDim flV(0 To Selection.Rows.CountLarge - 2)
For Each WS In Worksheets
Select Case WS.Name
Case Sheet1.Name, Sheet2.Name, Sheet3.Name ' Determine the location of the sheet to be filtered (source table)
For Each lobTable In WS.ListObjects
' Apply filter in the tables.
Dim ct As Integer, cf As Integer, j As Integer, i As Integer
For ct = 1 To lobTable.DataBodyRange.Columns.Count
For cf = 1 To fltrs.Columns.Count
' Build array with filter values.
j = 0
For i = LBound(flV) To UBound(flV)
If fltrs.Cells(i + 2, cf) <> "" Then
flV(i) = CStr(fltrs.Cells(i + 2, cf))
Else
flV(i) = ""
j = j + 1
End If
Next i
' Check if headers match.
If CStr(lobTable.Range.Cells(1, ct)) = fltrs.Cells(1, cf) Then
' Clear filter.
lobTable.Range.AutoFilter Field:=ct
' Apply new filter.
If UBound(flV) <> j - 1 Then
lobTable.Range.AutoFilter Field:=ct, Criteria1:=flV, Operator:=xlFilterValues
End If
End If
Next cf
Next ct
' Copy filtered tables.
Dim rng As Range
Dim Row As Range
Dim Lrow As Integer
Set rng = Nothing
For Each Row In lobTable.DataBodyRange.Rows
If Row.EntireRow.Hidden = False Then
If rng Is Nothing Then Set rng = Row
Set rng = Union(Row, rng)
End If
Next Row
Lrow = Sheet5.ListObjects(1).Range.Rows.Count
If Not rng Is Nothing Then
If Lrow > 2 Then Lrow = Lrow + 1
rng.Copy Sheet5.ListObjects(1).Range(Lrow, "A")
End If
Next lobTable
End Select
Next WS
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The problem is, the source table that will be used later are not the same (as shown in the following figure). With the same filter criteria, I didn't get the right results. Can I be helped to fix it? I am open to other solutions. Thank you.