Excel VBA如何根据条件将某些数据列从一个表复制到另一个表？

Question

在Excel中使用VBA，如何根据Table1单行Name列中的值将Table2某些列的数据复制到Table3？

表2(原始数据，位于工作表2中)

<表类=“s-表”> <标题> 日期1 日期2 日期3 姓名 文本 <正文> 日期 日期 日期 默认 文本 日期 日期 日期 默认 文本 日期 日期 日期 默认 文本 日期 日期 日期 乔恩·多伊 文本 日期 日期 日期 乔恩·多伊 文本 日期 日期 日期 乔恩·多伊 文本 日期 日期 日期 乔恩·多伊 文本 日期 日期 日期 无名氏 文本 日期 日期 日期 无名氏 文本 日期 日期 日期 无名氏 文本 日期 日期 日期 无名氏 文本 日期 日期 日期 无名氏 文本 日期 日期 日期 无名氏 文本

示例 1:

Table1(表1只有1行数据，位于Worksheet1中)

<表类=“s-表”> <标题> 无关数据1 无关数据2 无关数据3 无关数据4 姓名 <正文> 随机数据 其他数据 更多数据 一些数据 约翰·多伊

Table3(所需输出，位于 Worksheet1 中，行仅是 Table2 中的 John Doe 行)

<表类=“s-表”> <标题> 已选择 日期1 日期2 日期3 文本 <正文> 日期 日期 日期 文本 日期 日期 日期 文本 日期 日期 日期 文本 日期 日期 日期 文本

示例 2:

Table1(表1只有1行数据，位于Worksheet1中，名称为空)

<表类=“s-表”> <标题> 无关数据1 无关数据2 无关数据3 无关数据4 姓名 <正文> 随机数据 其他数据 更多数据 一些数据

Table3(所需输出，位于 Worksheet1 中，行只是 Table2 中的默认行)

<表类=“s-表”> <标题> 已选择 日期1 日期2 日期3 文本 <正文> 日期 日期 日期 文本 日期 日期 日期 文本 日期 日期 日期 文本

下面的解决方案(来自 VBA Copying data from one table to another and rearranging columns )几乎满足了我的需要，除了我需要能够根据 Table1 中的名称过滤 Table2 中的数据，如果名称为空，则使用默认数据由表 2 可知。感谢您的帮助!

    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

如果您想在传输数据之前使用过滤器，则需要事先将其应用到源站。

您可以使用 Autofilter 来做到这一点，如下所示:

    '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

过滤器的作用基本上是隐藏不符合条件的行(零高度)，因此当您传输数据时，需要确保仅使用可见行 .SpecialCells( xlCellTypeVisible) 例如。

把这些放在一起会得到:

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

之前

之后

请注意，这将使您的源表处于过滤模式。如果出现问题，您可以随时在末尾添加 SourceTable.AutoFilter.ShowAllData。

编辑1:如果您想保留格式，可以使用Copy方法而不是仅传输值，但请注意，这会比较慢。

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

编辑2: 要处理引用名称与源表中的任何名称都不匹配的情况，您可以在过滤器后添加检查，如果过滤表中不存在数据，则使用“默认”过滤器重新运行过滤器。

    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