Excel VBA需求：将缺失编号与对应列名拼接后导出

问题描述 #

我有一个用于追踪缺失编号的Excel表格，列数不固定（范围为A1:??），缺失编号会放在对应数据列的下一列（如E列数据缺失则记录在F列）。现有VBA宏可成功导出所有“Missing #”列的编号，但我需要将缺失编号与前一列的列名拼接成“列名 - 缺失编号”的格式后导出，而非仅导出缺失编号。

当前导出效果：

Missing #  Missing #  Missing#
2          5          8
           6

期望导出效果：

Column 1 - 2
Column 2 - 5
Column 2 - 6
Column 3 - 8

现有代码：

Sub FindMissing()
    Application.ScreenUpdating = False
    Dim xRg As Range, xRgUni As Range, xFirstAddress As String, xStr As String, srcWB As Workbook
    Set srcWB = ThisWorkbook
    xStr = "Missing #"
    Set xRg = Rows(1).Find(xStr, , xlValues, xlWhole, , , True)
    If Not xRg Is Nothing Then
        xFirstAddress = xRg.Address
        Do
            Set xRg = Range("A1:Z1").FindNext(xRg)
            If xRgUni Is Nothing Then
                Set xRgUni = xRg
            Else
                Set xRgUni = Application.Union(xRgUni, xRg)
            End If
        Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)
    End If
    xRgUni.EntireColumn.Copy
    Workbooks.Add
    ActiveSheet.Paste
    fName = srcWB.Path & "\Missing UPCs" & ".csv"
    With ActiveWorkbook
        .SaveAs Filename:=fName, FileFormat:=xlCSV, CreateBackup:=False
        MsgBox "your missing numbers file " & vbNewLine & "has been saved!"
        .Close False
    End With
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

修改后的代码 #

Sub FindMissing()
    Application.ScreenUpdating = False
    Dim xRg As Range, xFirstAddress As String, xStr As String, srcWB As Workbook
    Dim destWB As Workbook, destWS As Worksheet
    Dim colName As String, missingVal As Variant
    Dim lastRow As Long, destRow As Long
    
    Set srcWB = ThisWorkbook
    xStr = "Missing #"
    Set xRg = srcWB.ActiveSheet.Rows(1).Find(xStr, , xlValues, xlWhole, , , True)
    
    ' 创建新工作簿用于输出结果
    Set destWB = Workbooks.Add
    Set destWS = destWB.Sheets(1)
    destRow = 1 ' 初始化目标行号
    
    If Not xRg Is Nothing Then
        xFirstAddress = xRg.Address
        Do
            ' 获取当前缺失列对应的前一列列名
            colName = srcWB.ActiveSheet.Cells(1, xRg.Column - 1).Value
            ' 找到当前缺失列的最后一行数据
            lastRow = srcWB.ActiveSheet.Cells(srcWB.ActiveSheet.Rows.Count, xRg.Column).End(xlUp).Row
            
            ' 遍历当前列的所有非空缺失编号
            For Each missingVal In srcWB.ActiveSheet.Range(xRg.Offset(1), srcWB.ActiveSheet.Cells(lastRow, xRg.Column))
                If Not IsEmpty(missingVal.Value) Then
                    ' 拼接格式并写入目标工作表
                    destWS.Cells(destRow, 1).Value = colName & " - " & missingVal.Value
                    destRow = destRow + 1
                End If
            Next missingVal
            
            ' 查找下一个"Missing #"列
            Set xRg = srcWB.ActiveSheet.Rows(1).FindNext(xRg)
        Loop While (Not xRg Is Nothing) And (xRg.Address <> xFirstAddress)
    End If
    
    ' 保存结果文件
    fName = srcWB.Path & "\Missing UPCs.csv"
    With destWB
        .SaveAs Filename:=fName, FileFormat:=xlCSV, CreateBackup:=False
        MsgBox "缺失编号文件已保存！" & vbNewLine & fName
        .Close False
    End With
    
    ' 恢复Excel设置
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

核心修改点 #

1. 替换整列复制逻辑：不再直接复制“Missing #”列，改为逐行处理每个非空缺失值，避免导出空行
2. 列名拼接：对每个“Missing #”列，获取其前一列的列名（通过xRg.Column - 1定位），拼接成“列名 - 缺失编号”格式
3. 目标写入优化：将所有拼接结果按顺序写入新工作簿的第一列，符合期望的单行输出格式
4. 细节优化：修改提示信息为中文，明确标注文件路径；限定查找范围为当前工作表，避免跨表错误

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