如何将Excel VBA输出的原因字符串拆分为规范表格

原代码将每个供应商的原因及出现次数拼接成字符串存入单个单元格，现在调整为每个原因作为独立行条目，对应重复的供应商名称，原因和出现次数分别存入单独单元格，方便后续数据处理。

修改后的完整VBA代码 #

Sub Top10Names()
    Dim dataSheet As Worksheet
    Dim reportSheet As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim nameColumn As Range
    Dim dateColumn As Range
    Dim targetMonth As Long
    Dim targetYear As Long
    Dim i As Long
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Set dataSheet = ThisWorkbook.Sheets("TestSheet")
    Set reportSheet = ThisWorkbook.Sheets("Makro")
    
    ' 清空报表旧数据，避免干扰新结果
    reportSheet.Range("A2:Z" & reportSheet.Rows.Count).ClearContents
    reportSheet.Range("A2:Z" & reportSheet.Rows.Count).ClearFormats
    
    lastRow = dataSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    Dim columnF As Range
    Set columnF = dataSheet.Range("F6:F" & lastRow)
    
    Set dataRange = dataSheet.Range("A6:C" & lastRow)
    Set nameColumn = dataRange.Columns(3)
    Set dateColumn = dataRange.Columns(1)
    
    targetMonth = InputBox("Bitte geben Sie den Zielmonat ein (1-12):")
    targetYear = InputBox("Bitte geben Sie das Zieljahr ein:")
    
    ' 统计指定年月内的供应商总出现次数
    For i = 1 To dataRange.Rows.Count
        If Month(dateColumn.Cells(i)) = targetMonth And Year(dateColumn.Cells(i)) = targetYear Then
            Namex = nameColumn.Cells(i)
            If dict.Exists(Namex) Then
                dict(Namex) = dict(Namex) + 1
            Else
                dict(Namex) = 1
            End If
        End If
    Next i
    
    ' 设置表头及格式
    reportSheet.Range("A1") = "Lieferant"
    reportSheet.Range("B1") = "Häufgkeit (Gesamt)"
    reportSheet.Range("C1") = "Grund"
    reportSheet.Range("D1") = "Häufgkeit (Grund)"
    
    With reportSheet.Range("A1:D1")
        .Interior.Color = vbBlack
        .Font.Color = vbWhite
        .Font.Bold = True
    End With
    
    Dim reportRow As Long
    reportRow = 2 ' 报表数据起始行
    
    ' 遍历Top10供应商
    For i = 0 To 9
        If dict.Count = 0 Then Exit For ' 供应商不足10个时提前退出
        
        Dim maxCount As Long, maxKey As String
        maxCount = 0
        For Each Key In dict.Keys()
            If dict(Key) > maxCount Then
                maxCount = dict(Key)
                maxKey = Key
            End If
        Next Key
        
        ' 统计当前供应商的各原因出现次数
        Dim reasons As Object
        Set reasons = CreateObject("Scripting.Dictionary")
        For j = 1 To dataRange.Rows.Count
            If nameColumn.Cells(j) = maxKey And Month(dateColumn.Cells(j)) = targetMonth And Year(dateColumn.Cells(j)) = targetYear Then
                reasonx = columnF.Cells(j)
                If reasons.Exists(reasonx) Then
                    reasons(reasonx) = reasons(reasonx) + 1
                Else
                    reasons(reasonx) = 1
                End If
            End If
        Next j
        
        ' 将每个原因单独写入一行
        For Each reasonKey In reasons.Keys()
            reportSheet.Cells(reportRow, 1) = maxKey
            reportSheet.Cells(reportRow, 2) = maxCount ' 供应商总出现次数
            reportSheet.Cells(reportRow, 3) = reasonKey
            reportSheet.Cells(reportRow, 4) = reasons(reasonKey) ' 该原因的出现次数
            reportRow = reportRow + 1 ' 切换到下一行
        Next reasonKey
        
        dict.Remove maxKey
    Next i
    
    ' 自动调整列宽适配内容
    reportSheet.Range("A:D").AutoFit
End Sub

关键修改说明 #

• 旧数据清理：添加报表区域清空逻辑，避免历史内容干扰新生成的结果
• 表头优化：新增明确的列标题，区分供应商总次数和单个原因的出现次数
• 逐行写入逻辑：移除字符串拼接代码，改为遍历原因字典，将每个原因作为独立行写入报表
• 动态行号管理：用reportRow变量跟踪当前写入位置，确保所有原因条目依次排列
• 格式优化：添加自动列宽调整，提升报表可读性

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