如何用VBA筛选指定客户数据并按公司代码分表带表头导出？

核心逻辑 #

• 定义目标客户列表，筛选源表D列中匹配的记录
• 按A列的公司代码对筛选结果分组
• 为每个公司代码创建（或复用）工作表，复制表头及对应记录到目标表

完整VBA代码 #

Sub SplitByCustomerAndCompany()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim customerList As Variant
    Dim companyCode As String
    Dim targetLastRow As Long
    
    ' 指定源工作表名称，替换为你的实际表名
    Set wsSource = ThisWorkbook.Worksheets("数据源")
    
    ' 替换为你的10个指定客户名称
    customerList = Array("客户A", "客户B", "客户C", "客户D", "客户E", "客户F", "客户G", "客户H", "客户I", "客户J")
    
    ' 获取源表D列最后一行行号
    lastRow = wsSource.Cells(wsSource.Rows.Count, "D").End(xlUp).Row
    
    ' 定义表头范围（A1到AC1，假设表头在第1行）
    Dim headerRange As Range
    Set headerRange = wsSource.Range("A1:AC1")
    
    ' 遍历源表数据行（从第2行开始跳过表头）
    For i = 2 To lastRow
        ' 检查当前行客户是否在目标列表中
        If IsInArray(wsSource.Cells(i, "D").Value, customerList) Then
            companyCode = wsSource.Cells(i, "A").Value
            
            ' 检查是否已存在对应公司代码的工作表
            On Error Resume Next
            Set wsTarget = ThisWorkbook.Worksheets(companyCode)
            On Error GoTo 0
            
            ' 不存在则新建工作表并复制表头
            If wsTarget Is Nothing Then
                Set wsTarget = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
                wsTarget.Name = companyCode
                headerRange.Copy wsTarget.Range("A1")
            End If
            
            ' 找到目标表最后一行，准备追加数据
            targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
            
            ' 复制当前行A-AC列数据到目标表
            wsSource.Range("A" & i & ":AC" & i).Copy wsTarget.Range("A" & targetLastRow)
            
            Set wsTarget = Nothing
        End If
    Next i
    
    MsgBox "数据拆分完成！"
End Sub

' 辅助函数：检查值是否在数组内
Function IsInArray(valToCheck As Variant, arr As Variant) As Boolean
    Dim element As Variant
    For Each element In arr
        If element = valToCheck Then
            IsInArray = True
            Exit Function
        End If
    Next element
    IsInArray = False
End Function

使用步骤 #

1. 打开目标Excel文件，按Alt+F11打开VBA编辑器
2. 右键点击项目窗口中的工作簿名称 → 插入 → 模块
3. 将上述代码粘贴到模块中
4. 修改代码中wsSource = ThisWorkbook.Worksheets("数据源")的"数据源"为你的源工作表名称
5. 修改customerList = Array(...)中的客户名称为你的10个指定客户
6. 返回Excel，按Alt+F8，选择SplitByCustomerAndCompany并执行

注意事项 #

• 若公司代码包含工作表名称禁用字符（如/、\、*、?、:、[、]），需提前清理，否则新建工作表会报错
• 若表头不在第1行，需调整headerRange的范围及循环起始行i=2的数值
• 重复公司代码的记录会自动追加到对应工作表的末尾

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