Excel VBA how to copy certain columns of data from one table to another based on criteria?

Question

In Excel using VBA, how to copy data from certain columns of Table2 to Table3 based on the value in the the Name column in the single row of Table1?

Table2 (raw data, located in Worksheet2)

Date1	Date2	Date3	Name	Text
date	date	date	Default	text
date	date	date	Default	text
date	date	date	Default	text
date	date	date	Jon Doe	text
date	date	date	Jon Doe	text
date	date	date	Jon Doe	text
date	date	date	Jon Doe	text
date	date	date	Jane Doe	text
date	date	date	Jane Doe	text
date	date	date	Jane Doe	text
date	date	date	Jane Doe	text
date	date	date	Jane Doe	text
date	date	date	Jane Doe	text

Example 1:

Table1 (Table 1 only has 1 row of data, located in Worksheet1)

UnrelatedData1	UnrelatedData2	UnrelatedData3	UnrelatedData4	Name
random data	other data	more data	some data	John Doe

Table3 (desired output, located in Worksheet1, rows are only the John Doe rows from Table2)

Selected	Date1	Date2	Date3	Text
	date	date	date	text
	date	date	date	text
	date	date	date	text
	date	date	date	text

Example 2:

Table1 (Table 1 only has 1 row of data, located in Worksheet1, Name is blank)

UnrelatedData1	UnrelatedData2	UnrelatedData3	UnrelatedData4	Name
random data	other data	more data	some data

Table3 (desired output, located in Worksheet1, rows are only the Default rows from Table2)

Selected	Date1	Date2	Date3	Text
	date	date	date	text
	date	date	date	text
	date	date	date	text

The solution below (from VBA Copying data from one table to another and rearranging columns) almost does what I need, except that I need to be able to filter the data from Table2 based on the name in Table1 and, if the name is blank, then use the Default data from Table2. Thank you for your help!

    Option Explicit

    Sub raw2processed()

    Dim lc As Long, mc As Variant, x As Variant
    Dim raw_data As Worksheet, processed_data As Worksheet
    Dim raw_tbl As ListObject, processed_tbl As ListObject

    Set raw_data = Worksheets("raw")
    Set processed_data = Worksheets("processed")
    Set raw_tbl = raw_data.ListObjects("tbl_raw")
    Set processed_tbl = processed_data.ListObjects("tbl_processed")

    With processed_tbl
        'clear target table
        On Error Resume Next
        .DataBodyRange.Clear
        .Resize .Range.Resize(raw_tbl.ListRows.Count + 1, .ListColumns.Count)
        On Error GoTo 0

        'loop through target header and collect columns from raw_tbl
        For lc = 1 To .ListColumns.Count
            Debug.Print .HeaderRowRange(lc)
            mc = Application.Match(.HeaderRowRange(lc), raw_tbl.HeaderRowRange, 0)
            If Not IsError(mc) Then
                x = raw_tbl.ListColumns(mc).DataBodyRange.Value
                .ListColumns(lc).DataBodyRange = x
            End If
        Next lc

    End With

    End Sub

Answer 1

If you want to use a filter before transfering the data, you need to apply it to the source origin beforehand.

You can do that with Autofilter with something like this:

    'Filter the data to use only supplied Name
    Dim FilterColumn As Long
    FilterColumn = Application.Match(FilterName, SourceTable.HeaderRowRange, 0)
    SourceTable.DataBodyRange.AutoFilter Field:=FilterColumn, Criteria1:=Criteria

What the filter does is basically make the rows that don't match the criteria hidden (zero height), so when you transfer the data, you need to make sure that you use only visible rows with .SpecialCells(xlCellTypeVisible) for instance.

Putting this all together would give:

Sub Test()

    'Define your main tables
    Dim SourceTable As ListObject
    Set SourceTable = ThisWorkbook.Worksheets("Sheet2").ListObjects("Table2")
    
    Dim DestTable As ListObject
    Set DestTable = ThisWorkbook.Worksheets("Sheet3").ListObjects("Table3")
    
    'Define the filter values
    Dim RefTable As ListObject
    Set RefTable = ThisWorkbook.Worksheets("Sheet1").ListObjects("Table1")
    
    Dim FilterName As String
    FilterName = "Name"
    
    'Define filter
    Dim NameValue As String, col As Long
    col = Application.Match("Name", RefTable.HeaderRowRange, 0)
    NameValue = RefTable.DataBodyRange.Cells(1, col)
    
    If NameValue = "" then
        NameValue = "Default"
    End If

    CopyFilteredTable FilterName, NameValue, SourceTable, DestTable

End Sub

Sub CopyFilteredTable(ByVal FilterName As Variant, ByVal Criteria As Variant, SourceTable As ListObject, DestTable As ListObject)
   
    'Filter the data to use only supplied criteria
    Dim FilterColumn As Long
    FilterColumn = Application.Match(FilterName, SourceTable.HeaderRowRange, 0)
    SourceTable.DataBodyRange.AutoFilter Field:=FilterColumn, Criteria1:=Criteria
    
    With DestTable
    
        'Clear destination table
        On Error Resume Next
            .DataBodyRange.Clear
            .Resize .Range.Resize(SourceTable.ListRows.SpecialCells(xlCellTypeVisible).Count + 1, .ListColumns.Count)
        On Error GoTo 0

        'Loop through target header and collect columns from Source Table
        Dim lc As Long
        For lc = 1 To .ListColumns.Count
            
            Dim mc As Variant
            mc = Application.Match(.HeaderRowRange(lc), SourceTable.HeaderRowRange, 0)
                        
            If Not IsError(mc) Then
            
                Dim ColRange As Range
                Set ColRange = SourceTable.ListColumns(mc).DataBodyRange.SpecialCells(xlCellTypeVisible)
                
                .ListColumns(lc).DataBodyRange.Resize(ColRange.Rows.Count, ColRange.Columns.Count).Value2 = ColRange.Value2
                
            End If
            
        Next lc

    End With

End Sub

Before

After

Note that this will leave your Source Table is filtered mode. You can always add SourceTable.AutoFilter.ShowAllData at the end if that's a problem.

EDIT 1: If you want to preserve formatting, you can use the Copy method instead of transferring only the values, but note that this will be slower.

ColRange.Copy Destination:=.ListColumns(lc).DataBodyRange.Resize(ColRange.Rows.Count, ColRange.Columns.Count)

EDIT2: To handle the case where the reference name doesn't match any names in the source table, you can add a check after the filter and re-run the filter with the "Default" filter if no data is present in the filtered table.

    On Error Resume Next
        Dim test As String
        test = SourceTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Address
        If Err.Number = 1004 Then 'No cells were found.
            SourceTable.DataBodyRange.AutoFilter Field:=FilterColumn, Criteria1:="Default"
        Else
            Err.Raise Err.Number, Err.Source, Err.Description
        End If
    On Error GoTo 0