如何用VBA将D列筛选后的带表头数据汇总到单个工作表？

修改后代码 #

Sub CopyFilteredDataToOneSheet()
    Dim r As Integer, Account As String
    Dim targetSheet As Worksheet
    Dim lastRow As Long
    
    ' 创建或获取汇总用的目标工作表
    On Error Resume Next
    Set targetSheet = ThisWorkbook.Worksheets("筛选汇总")
    If Err.Number <> 0 Then
        Set targetSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        targetSheet.Name = "筛选汇总"
    End If
    On Error GoTo 0
    
    With Worksheets("Sheet1")
        .Range("A1:Z1").AutoFilter
        ' 仅在目标表为空时复制表头
        If targetSheet.Cells(Rows.Count, 1).End(xlUp).Row = 1 And targetSheet.Cells(1, 1).Value = "" Then
            .Range("A1:Z1").Copy targetSheet.Range("A1")
        End If
        
        For r = 2 To 24
            Account = .Range("D" & r).Value
            ' 跳过空账号
            If Account = "" Then GoTo NextAccount
            
            ' 筛选当前账号数据
            .Range("A1:Z1").AutoFilter Field:=4, Criteria1:=Account
            
            ' 复制筛选后的有效数据行（跳过表头）
            On Error Resume Next
            .Range("A2:Z" & .Cells(.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy
            On Error GoTo 0
            
            ' 粘贴到目标表的最后一行下方
            If Err.Number = 0 Then
                lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
                targetSheet.Range("A" & lastRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
            
            ' 重置筛选状态
            .ShowAllData
NextAccount:
        Next r
        ' 关闭原表筛选
        .AutoFilterMode = False
    End With
    
    ' 清除复制状态
    Application.CutCopyMode = False
End Sub

修改说明 #

• 新增targetSheet变量统一管理汇总工作表，自动创建名为「筛选汇总」的工作表（不存在时创建）
• 仅在目标表为空时复制一次表头，避免重复追加表头
• 筛选后只复制数据行（从A2开始），粘贴到目标表的最后一行下方，实现数据依次追加
• 增加空账号判断，跳过无效筛选
• 操作结束后关闭原表筛选、清除复制状态，避免Excel残留异常状态

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