Incorrect results when copying filtered table data

ybr_15

Board Regular
Joined
May 24, 2016
Messages
194
Office Version
  1. 2019
  2. 2013
Platform
  1. Windows
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:
Pict_10.jpg
Pict_11.jpg
Pict_12.jpg

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.
Pict_13.jpg
Pict_14.jpg
 

Excel Facts

Format cells as time
Select range and press Ctrl+Shift+2 to format cells as time. (Shift 2 is the @ sign).

Watch MrExcel Video

Forum statistics

Threads
1,133,625
Messages
5,659,941
Members
418,538
Latest member
alc51103

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
Top