求适配动态表格的VBA代码：按列筛选并整理数据

核心代码 #

Sub ProcessDynamicTable()
    Dim srcWs As Worksheet, newWs As Worksheet
    Dim lastCol As Long, lastRow As Long, currentCol As Long
    Dim targetRow As Long
    Dim dateVal As String
    
    ' 设定源工作表（默认当前活动表，可自行修改为具体表名如Sheet1）
    Set srcWs = ActiveSheet
    ' 检查并创建NEW工作表
    On Error Resume Next
    Set newWs = ThisWorkbook.Worksheets("NEW")
    If Err.Number <> 0 Then
        Set newWs = ThisWorkbook.Worksheets.Add(After:=srcWs)
        newWs.Name = "NEW"
        ' 给NEW表添加表头
        newWs.Range("A1:E1") = Array("A列数据", "B列数据", "C列数据", "数值", "日期")
    End If
    On Error GoTo 0
    
    ' 动态获取源表最后一列（从表头行找最后有数据的列）
    lastCol = srcWs.Cells(1, srcWs.Columns.Count).End(xlToLeft).Column
    ' 从D列（第4列）开始循环处理每一列
    For currentCol = 4 To lastCol
        ' 获取当前列的日期（假设日期在表头第一行）
        dateVal = srcWs.Cells(1, currentCol).Value
        ' 取消之前的筛选状态
        srcWs.AutoFilterMode = False
        ' 动态获取当前列最后一行数据行号
        lastRow = srcWs.Cells(srcWs.Rows.Count, currentCol).End(xlUp).Row
        ' 对当前列执行筛选：值>0
        srcWs.Range(srcWs.Cells(1, 1), srcWs.Cells(lastRow, lastCol)).AutoFilter Field:=currentCol, Criteria1:=">0"
        
        ' 获取NEW表下一个空行的行号（从表头下一行开始）
        targetRow = newWs.Cells(newWs.Rows.Count, 1).End(xlUp).Row + 1
        
        ' 复制A-C列的可见行数据到NEW表
        srcWs.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy
        newWs.Range("A" & targetRow).PasteSpecial xlPasteValues
        
        ' 复制当前列的筛选后数值到NEW表D列
        srcWs.Range(srcWs.Cells(2, currentCol), srcWs.Cells(lastRow, currentCol)).SpecialCells(xlCellTypeVisible).Copy
        newWs.Range("D" & targetRow).PasteSpecial xlPasteValues
        
        ' 批量填充日期到NEW表E列
        newWs.Range("E" & targetRow & ":E" & (targetRow + srcWs.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Rows.Count - 1)).Value = dateVal
        
        ' 取消当前列筛选，避免影响下一轮循环
        srcWs.AutoFilterMode = False
    Next currentCol
    
    ' 自动调整NEW表列宽
    newWs.Columns.AutoFit
    MsgBox "数据处理完成！"
End Sub

关键功能说明 #

• 动态范围适配：通过End(xlToLeft)和End(xlUp)自动获取表格的最后列、最后行，彻底解决录制宏固定范围的问题。
• 工作表自动创建：先检查NEW表是否存在，不存在则自动新建并添加表头。
• 精准筛选复制：使用SpecialCells(xlCellTypeVisible)仅复制筛选后的有效行，避免复制空行或不符合条件的数据。
• 高效日期填充：通过批量赋值的方式填充日期，比逐行粘贴效率更高。
• 循环清理机制：每次循环后取消筛选，确保下一轮筛选不受之前状态影响。

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