VBA代码修改：按指定条件合并客户数据导出文件

原代码功能：将工作表Teststruktur中B列为Ja的行导出为独立工作簿。

需求调整：

• 当某行B列存在指定值（Ja）时，将A列同名客户的所有对应行合并到同一个工作簿中
• 当某行B列无指定值时，仍为该行生成独立工作簿

修改后的代码 #

Sub KundendatenExport()
    Dim ws As Worksheet
    Dim rng As Range
    Dim c As Range
    Dim wb As Workbook
    Dim DestPath As String
    Dim lastRow As Long
    Dim clientName As String
    Dim targetRow As Long
    Dim processedClients As Collection ' 记录已处理过的合并客户

    ' 设置保存路径（需自行调整）
    DestPath = SpeicherOrt
    ' 确保路径末尾有斜杠，避免文件名拼接错误
    If Right(DestPath, 1) <> "\" Then DestPath = DestPath & "\"

    ' 初始化已处理客户集合
    Set processedClients = New Collection
    Set ws = ThisWorkbook.Sheets("Teststruktur")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set rng = ws.Range("A2:A" & lastRow)

    ' 遍历所有行
    For Each c In rng
        If c.Value = "" Then Exit For ' 遇到空行终止循环
        
        clientName = c.Value
        
        ' 情况1：B列为"Ja"，且该客户未被处理过
        If ws.Cells(c.Row, "B").Value = "Ja" Then
            On Error Resume Next
            processedClients.Add clientName, Key:=clientName
            On Error GoTo 0
            
            ' 仅当客户是首次遇到时，创建合并工作簿
            If Err.Number = 0 Then
                Set wb = Workbooks.Add
                ' 复制表头
                ws.Rows(1).Copy Destination:=wb.Sheets(1).Rows(1)
                targetRow = 2
                
                ' 查找当前客户的所有行并复制
                For Each rowInRange In ws.Range("A2:A" & lastRow)
                    If rowInRange.Value = clientName Then
                        ws.Range("A" & rowInRange.Row & ":AD" & rowInRange.Row).Copy _
                            Destination:=wb.Sheets(1).Rows(targetRow)
                        targetRow = targetRow + 1
                    End If
                Next rowInRange
                
                ' 保存并关闭合并工作簿
                wb.SaveAs DestPath & clientName & "_KW" & Format(Now, "ww") & ".xlsx", _
                    FileFormat:=xlOpenXMLWorkbook
                wb.Close SaveChanges:=False
            End If
        Else
            ' 情况2：B列不是"Ja"，生成独立工作簿
            Set wb = Workbooks.Add
            ws.Rows(1).Copy Destination:=wb.Sheets(1).Rows(1)
            ws.Range("A" & c.Row & ":AD" & c.Row).Copy Destination:=wb.Sheets(1).Rows(2)
            
            ' 按客户名+当前行D列值+周数命名
            wb.SaveAs DestPath & clientName & ws.Cells(c.Row, "D").Value & "_KW" & Format(Now, "ww") & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook
            wb.Close SaveChanges:=False
        End If
    Next c
End Sub

代码说明 #

• 使用Collection记录已处理的合并客户，避免重复生成同一客户的合并文件
• 对B列为Ja的客户，一次性查找并复制其所有行到同一个工作簿
• 确保保存路径末尾带斜杠，防止文件名拼接出错
• 为合并文件和独立文件设置了清晰的命名规则，区分不同类型的导出结果

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