基于主Excel文件按唯一姓名提取对应保单号生成新文件的VBA问题

核心问题 #

你的代码会重复覆盖文件，是因为同一个姓名在unique names工作表中存在多行条目，代码遍历每一行时都会单独打开主文件、过滤对应保单号、保存同名文件，后一次操作会覆盖前一次的结果。另外，当前逻辑没有先汇总同一姓名的所有保单号，而是逐条处理，导致最终文件只保留最后一次处理的保单号数据。

修改后的代码 #

Sub SaveMasterAS()
    Dim masterWB As Workbook
    Dim rNames As Range, c As Range
    Dim masterPath As String, savePath As String
    Dim errorSheet As Worksheet
    Dim errorRow As Long, errorOccurred As Boolean
    Dim newFileName As String
    Dim nameVal As String, policyVal As String
    Dim policyDict As Object
    Dim exportWS As Worksheet
    Dim r As Long

    ' 定义路径
    masterPath = "\\Products\Implementation Documents\BRS_MainDatacopy.xlsm"
    savePath = "\\Products\Implementation Documents\Checklists\"

    ' 初始化错误日志工作表
    On Error Resume Next
    Set errorSheet = ThisWorkbook.Sheets("Error Log")
    If errorSheet Is Nothing Then
        Set errorSheet = ThisWorkbook.Sheets.Add
        errorSheet.Name = "Error Log"
        errorSheet.Range("A1:C1").Value = Array("姓名", "保单号", "错误信息")
    End If
    On Error GoTo 0
    errorRow = errorSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

    ' 创建字典存储姓名对应的所有保单号
    Set policyDict = CreateObject("Scripting.Dictionary")
    Set rNames = Worksheets("unique names").Range("C2", Worksheets("unique names").Range("C2").End(xlDown))
    
    ' 先汇总同一姓名的所有保单号
    For Each c In rNames
        nameVal = Trim(c.Value)
        If nameVal = "Ahmad Test" Then ' 仅测试该姓名
            policyVal = Trim(c.Offset(0, -1).Value) ' 获取B列的保单号
            If policyVal <> "" Then
                ' 拆分保单号并加入字典
                policyVal = Replace(policyVal, ";", ",")
                Dim policyArr() As String, i As Integer
                policyArr = Split(policyVal, ",")
                For i = LBound(policyArr) To UBound(policyArr)
                    Dim cleanPolicy As String
                    cleanPolicy = Trim(policyArr(i))
                    If cleanPolicy <> "" Then
                        ' 避免重复添加同一保单号
                        If Not policyDict.exists(cleanPolicy) Then
                            policyDict(cleanPolicy) = True
                        End If
                    End If
                Next i
            End If
        End If
    Next c

    ' 如果该姓名有保单号，再处理主文件
    If policyDict.Count > 0 Then
        nameVal = "Ahmad Test"
        ' 打开主工作簿
        On Error GoTo MasterOpenError
        Set masterWB = Workbooks.Open(masterPath)
        Set exportWS = masterWB.Sheets("DataTable")

        ' 反向删除无关行（反向删除避免漏删）
        r = exportWS.Cells(exportWS.Rows.Count, "C").End(xlUp).Row
        Do While r >= 2 ' 从最后一行往上删，表头在第1行
            If Not policyDict.exists(Trim(exportWS.Cells(r, 3).Value)) Then
                exportWS.Rows(r).Delete
            End If
            r = r - 1
        Loop

        ' 自动调整列宽
        exportWS.Columns.AutoFit

        ' 保存文件（仅执行一次）
        On Error GoTo SaveError
        newFileName = "BRS_2026_Template_" & nameVal & ".xlsm"
        masterWB.SaveAs Filename:=savePath & newFileName, _
                        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        On Error GoTo 0

        ' 关闭主文件，不保存源文件的修改
        masterWB.Close SaveChanges:=False
        MsgBox "Ahmad Test的测试文件已成功保存，包含" & policyDict.Count & "条保单数据！", vbInformation
    Else
        MsgBox "未找到Ahmad Test对应的保单号！", vbExclamation
    End If

    If errorOccurred Then
        MsgBox "部分文件保存失败，请查看'Error Log'工作表获取详情。", vbExclamation
    End If

    Exit Sub

MasterOpenError:
    MsgBox "无法打开主模板文件，请检查路径是否正确后重试。", vbCritical
    Exit Sub

SaveError:
    errorSheet.Cells(errorRow, 1).Value = nameVal
    errorSheet.Cells(errorRow, 2).Value = Join(policyDict.keys(), ", ")
    errorSheet.Cells(errorRow, 3).Value = Err.Description
    errorRow = errorRow + 1
    errorOccurred = True
    Resume Next
End Sub

关键修改说明 #

• 先汇总保单号：不再逐条处理姓名条目，而是先遍历所有行，把同一姓名的所有保单号收集到字典中（自动去重），确保一次性获取该姓名的全部保单号。
• 反向删除行：原代码正向删除行时，删除一行后后续行会前移，容易漏删数据；改为从最后一行往上删，避免这个问题。
• 单次处理主文件：汇总完所有保单号后，只打开一次主文件，过滤出所有目标保单号，保存一次文件，彻底解决覆盖问题。
• 去重处理：字典自动过滤重复的保单号，避免同一保单号多次出现在结果中。

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