从一个列表创建单独文件的 VBA 代码

Question

我有这个VBA代码：

Sub KundendatenExport()
    Dim ws As Worksheet
    Dim rng As Range
    Dim c As Range
    Dim wb As Workbook
    Dim DestPath As String

    ' Set the destination path (you need to adjust this)
    DestPath = SpeicherOrt

    ' Set the worksheet containing the list
    Set ws = ThisWorkbook.Sheets("Teststruktur")
    
    ' Set the range of the list
    Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)

    ' Loop through each cell in the range
    For Each c In rng
        ' Check if the row is empty
        If c.Value <> "" Then
            ' Check if column B value is "Ja"
            If ws.Cells(c.Row, "B").Value = "Ja" Then
                ' Create a new workbook
                Set wb = Workbooks.Add
                
                ' Copy the headers from the main list
                ws.Rows(1).Copy Destination:=wb.Sheets(1).Rows(1)
                
                ' Copy the current row
                ws.Range("A" & c.Row & ":AD" & c.Row).Copy Destination:=wb.Sheets(1).Rows(2)
                
                ' Save the new workbook with the client name and calendar week
                wb.SaveAs DestPath & c.Value & ws.Cells(c.Row, "D").Value & "KW" & Format(Now, "ww"), FileFormat:=xlOpenXMLWorkbook
                wb.Close SaveChanges:=False
            End If
        Else
            Exit For ' Exit the loop if the row is empty
        End If
    Next c
End Sub

这通常是有效的。但现在我需要程序只为客户创建一个文件，如果在 b 行中找到特定值，则 a 行中具有相同名称的所有数据都应放入同一文件中。如果特定值不存在，则只需创建一个新文件

谢谢

我只想让它发挥作用，我很累

Answer 1

• 假设客户姓名位于 A 栏
• 使用Dictionary对象来整合每个客户的所有数据

• ws.Cells(c.Row, "D").Value

  从文件名中删除

Option Explicit

Sub KundendatenExport()
    Dim ws As Worksheet
    Dim rng As Range
    Dim wb As Workbook
    Dim DestPath As String
    Dim objDic As Object, sKey
    Set objDic = CreateObject("scripting.dictionary")
    ' Set the destination path (you need to adjust this)
    DestPath = "D:\temp\" ' for testing
'    DestPath = SpeicherOrt
    ' Set the worksheet containing the list
    Set ws = ThisWorkbook.Sheets(1) ' for testing
'    Set ws = ThisWorkbook.Sheets("Teststruktur")
    ' Set the range of the list
    Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Resize(, 2)
    Dim arrData: arrData = rng.Value
    ' Loop through each cell in the range
    Dim i As Long
    For i = 1 To UBound(arrData)
        ' Check if the row is empty
        sKey = arrData(i, 1)
        If Len(sKey) > 0 Then
            If Not objDic.exists(sKey) Then
                Set objDic(sKey) = ws.Cells(1, "A")
            End If
            ' Check if column B value is "Ja"
            If arrData(i, 2) = "Ja" Then
                Set objDic(sKey) = Application.Union(objDic(sKey), ws.Cells(i + 1, "A"))
            End If
        End If
    Next
    Application.ScreenUpdating = False
    For Each sKey In objDic.Keys
        Set wb = Workbooks.Add
        If objDic(sKey).Cells.Count > 1 Then
            objDic(sKey).EntireRow.Copy Destination:=wb.Sheets(1).Range("A1")
        End If
        wb.SaveAs DestPath & sKey & "KW" & Format(Now, "ww"), FileFormat:=xlOpenXMLWorkbook
        wb.Close SaveChanges:=False
    Next
    Application.ScreenUpdating = False
    MsgBox "Done"
End Sub