VBA技术需求：复制表格可见行及选中行至指定报表表格

需求说明 #

1. 从工作表Oculus Trans的17列主表中，筛选出今日到达的拖车记录，仅将筛选后的可见行数据复制到报表工作表的Table9，要求保持表头匹配
2. 新增独立按钮功能：将Oculus Trans主表中用户选中并高亮的多行数据，复制到报表工作表的tblSOSTrailersToBeReceived，同样保持表头匹配

原参考代码

Sub TransArrivals()

    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("Oculus Trans")
    Set processed_data = Worksheets("SOS_Report")
    Set raw_tbl = raw_data.ListObjects("Table9")
    Set processed_tbl = processed_data.ListObjects("tblTransArrival")
    
    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
        
        On Error Resume Next
        '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

需求1实现代码：筛选今日数据并复制可见行 #

Sub CopyTodayArrivalsToTable9()
    Dim rawWs As Worksheet, reportWs As Worksheet
    Dim rawTbl As ListObject, targetTbl As ListObject
    Dim filterCol As ListColumn, visibleData As Range
    Dim lc As Long, mc As Variant, tempArr As Variant
    Dim todayDate As Date
    
    ' 初始化工作表和表格对象
    Set rawWs = Worksheets("Oculus Trans")
    Set reportWs = Worksheets("SOS_Report") ' 若Table9不在此表，请修改
    Set rawTbl = rawWs.ListObjects(1) ' 主表为Oculus Trans中第一个表格，有名称可改为ListObjects("主表名称")
    Set targetTbl = reportWs.ListObjects("Table9")
    
    todayDate = Date ' 获取今日日期
    
    ' 清空目标表格原有数据
    On Error Resume Next
    targetTbl.DataBodyRange.Clear
    On Error GoTo 0
    
    ' 筛选主表中"到达日期"列（替换为实际表头名称）
    Set filterCol = rawTbl.ListColumns("到达日期")
    rawTbl.Range.AutoFilter Field:=filterCol.Index, Criteria1:=todayDate
    
    ' 获取筛选后的可见数据（排除表头）
    On Error Resume Next
    Set visibleData = rawTbl.DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If Not visibleData Is Nothing Then
        With targetTbl
            ' 调整目标表格行数匹配可见行数量
            If .ListRows.Count < visibleData.Rows.Count Then
                .Resize .Range.Resize(visibleData.Rows.Count + 1, .ListColumns.Count)
            End If
            
            ' 按表头匹配复制对应列数据
            For lc = 1 To .ListColumns.Count
                mc = Application.Match(.HeaderRowRange(lc), rawTbl.HeaderRowRange, 0)
                If Not IsError(mc) Then
                    tempArr = rawTbl.ListColumns(mc).DataBodyRange.SpecialCells(xlCellTypeVisible).Value
                    .ListColumns(lc).DataBodyRange.Resize(UBound(tempArr, 1)).Value = tempArr
                End If
            Next lc
        End With
    End If
    
    ' 取消主表筛选
    rawTbl.Range.AutoFilter Field:=filterCol.Index
End Sub

关键提示：

• 务必将代码中的**"到达日期"**替换为主表中存储到达日期的列的实际表头名称
• 若主表有明确名称，可将rawTbl = rawWs.ListObjects(1)改为rawWs.ListObjects("主表名称")

需求2实现代码：复制选中高亮行到指定表格 #

Sub CopySelectedHighlightedRowsToTarget()
    Dim rawWs As Worksheet, reportWs As Worksheet
    Dim rawTbl As ListObject, targetTbl As ListObject
    Dim selectedRows As Range, cell As Range
    Dim rowNum As Long, lc As Long, mc As Variant
    Dim targetRow As ListRow
    
    ' 初始化工作表和表格对象
    Set rawWs = Worksheets("Oculus Trans")
    Set reportWs = Worksheets("SOS_Report")
    Set rawTbl = rawWs.ListObjects(1) ' 主表对象，有名称可替换
    Set targetTbl = reportWs.ListObjects("tblSOSTrailersToBeReceived")
    
    ' 清空目标表格原有数据
    On Error Resume Next
    targetTbl.DataBodyRange.Clear
    On Error GoTo 0
    
    ' 获取主表内的选中范围
    Set selectedRows = Intersect(rawTbl.DataBodyRange, Selection)
    If selectedRows Is Nothing Then
        MsgBox "请在Oculus Trans主表中选中需要复制的行！"
        Exit Sub
    End If
    
    ' 遍历选中行，复制高亮行数据
    For Each cell In selectedRows.Columns(1).Cells
        rowNum = cell.Row - rawTbl.HeaderRowRange.Row
        
        ' 判断是否为高亮行（6代表黄色，替换为实际高亮颜色的ColorIndex）
        If cell.Interior.ColorIndex = 6 Then
            ' 在目标表新增行
            Set targetRow = targetTbl.ListRows.Add
            
            ' 按表头匹配复制每列数据
            For lc = 1 To targetTbl.ListColumns.Count
                mc = Application.Match(targetTbl.HeaderRowRange(lc), rawTbl.HeaderRowRange, 0)
                If Not IsError(mc) Then
                    targetRow.Range(lc).Value = rawTbl.ListColumns(mc).DataBodyRange(rowNum).Value
                End If
            Next lc
        End If
    Next cell
End Sub

关键提示：

• 高亮颜色判断使用Interior.ColorIndex = 6（黄色），可通过录制宏获取实际高亮颜色的索引值
• 若无需判断高亮，仅复制选中行，可删除If cell.Interior.ColorIndex = 6 Then及对应的End If

内容的提问来源于stack exchange，提问作者Lei