如何在VBA中修剪Dictionary（字典）内的内容？

我有一个Excel公式可以查找单元格中的倒数第N个单词并输出。目前我使用VBA宏将Sheet1中无序的数据整理后输出到Sheet2。

现在我想要在数据被复制到Sheet2之前，修改存储数据的Dictionary（字典）中的内容，使其在Sheet2中仅保留特定内容（如倒数第2/3个单词或仅数字）。

我知道在VBA中实现此功能的基础方法是：

Split(Sheets("reportsheet").Range("A1").Value, " ")(wordNumber - 1)

但我不清楚如何将其应用到我的场景中，我的VBA代码如下：

Sub findData()
    Dim datasheet As Worksheet
    Dim reportsheet As Worksheet
    Dim SearchString As String
    Dim i As Integer
    Dim j As Integer
    Set datasheet = Sheet1
    Set reportsheet = Sheet2
    Dim chNum As String 'Ticket number
    Dim chSub As String 'Change subject
    Dim rptNum As String 'analysis number
    Dim ChangeNumbers As New Dictionary 'dictionary that holds all of the info (ticket number, change subject, analysis number and details)
    Dim dictKey1 As Variant
    Dim dictKey2 As Variant
    Dim dictKey3 As Variant
    Dim dictKey4 As Variant
    Dim formula1 As String
    Dim formula2 As String
    
    reportsheet.Range("A1:H200").ClearContents
    finalrow1 = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row
    
    'Loop that finds the required pieces of text from the data-sheet
    For i = 1 To finalrow1
        'Basic info in column A
        SearchString = datasheet.Range("A" & i)
        If InStr(1, SearchString, "Change number") Then
            chNum = datasheet.Cells(i, 1)
            ChangeNumbers.Add chNum, New Dictionary 'For ticket numbers
        ElseIf InStr(1, SearchString, "Change subject") Then
            chSub = datasheet.Cells(i, 1)
            ChangeNumbers.Item(chNum).Add chSub, New Dictionary 'For change subjects
        ElseIf InStr(1, SearchString, "Report-") Then
            rptNum = datasheet.Cells(i, 1)
            ChangeNumbers.Item(chNum).Item(chSub).Add rptNum, New Dictionary 'For analysis
            
            'Loop for the details (requirements, tech.specs, impl. and testing)
            j = 0
            'Verifies that the details belong to the current report
            'String checks are included after locating a report to maintain a connection between the report and its details
            Do While IsEmpty(datasheet.Cells(i + j, 1)) Or datasheet.Cells(i + j, 1) = rptNum
                If InStr(1, datasheet.Cells(i + j, 2), "Priority") Then
                    ' The 4 after ".Add" is the column number for this detail in sheet2
                    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, datasheet.Cells(i + j, 2) ' the detail #1
                ElseIf InStr(1, datasheet.Cells(i + j, 2), "Workload") Then
                    ' The 5 after ".Add" is the column number for this detail in sheet2
                    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 5, datasheet.Cells(i + j, 2) ' the detail #2
                ElseIf InStr(1, datasheet.Cells(i + j, 2), "Deadline") Then
                    ' The 6 after ".Add" is the column number for this detail in sheet2
                    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 6, datasheet.Cells(i + j, 2) ' the detail #3
                End If
                j = j + 1
            Loop
        End If
    Next i
    
    i = 1
    For Each dictKey1 In ChangeNumbers.Keys
        reportsheet.Cells(i, 1) = dictKey1 'Change Ticket Number
        If ChangeNumbers.Item(dictKey1).Count > 0 Then
            For Each dictKey2 In ChangeNumbers.Item(dictKey1).Keys
                reportsheet.Cells(i, 2) = dictKey2 'Change Subject; assuming in column B on same row as Change Number
                If ChangeNumbers.Item(dictKey1).Item(dictKey2).Count > 0 Then
                    For Each dictKey3 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Keys 'Analysis number
                        reportsheet.Cells(i, 3) = dictKey3
                        'reportsheet.Cells(i, 2) = dictKey2 'Uncomment if you want change subject in every row w/ matching report
                        For Each dictKey4 In ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys
                            reportsheet.Cells(i, dictKey4) = ChangeNumbers.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4)
                        Next dictKey4
                        i = i + 1 'moves to new row for new report (or next change number)
                    Next dictKey3
                Else
                    i = i + 1 'no reports, so moves down to prevent overwriting change number
                End If
            Next dictKey2
        Else
            i = i + 1 'no change subject, so moves down to prevent overwriting change number
        End If
    Next dictKey1
End Sub

我觉得VBA函数的文档很难理解，找不到实际应用的方法。我尝试在数据存入Dictionary后修改内容，但没有成功，所有尝试要么导致循环停止要么报错。恳请各位提供可行的入手指导！

咱们先把核心问题拆解一下：你需要在数据进入字典之前（或者之后）处理字符串，提取特定内容。最稳妥的方式是在存入字典前就处理好数据——这样逻辑更清晰，也避免了后续遍历多层嵌套字典的麻烦。

第一步：封装通用处理函数 #

先写两个可复用的函数，一个用来提取倒数第N个单词，另一个提取纯数字。把这些函数放在你的宏模块里（和findData子过程同个模块）：

' 提取字符串中倒数第N个单词（按空格分隔，自动忽略首尾空格）
Function GetLastNthWord(inputStr As String, n As Integer) As String
    Dim wordArray() As String
    ' 先去除首尾空格，再按空格分割成数组
    wordArray = Split(Trim(inputStr), " ")
    
    ' 检查数组长度是否足够提取第N个倒数单词
    If UBound(wordArray) + 1 >= n Then
        ' UBound是数组最后一个元素的索引，所以倒数第n个就是 最后索引 - n + 1
        GetLastNthWord = wordArray(UBound(wordArray) - n + 1)
    Else
        ' 如果单词数量不够，直接返回原字符串（或者你可以返回空字符串，按需调整）
        GetLastNthWord = inputStr
    End If
End Function

' 提取字符串中的所有数字字符，返回纯数字字符串
Function ExtractNumbers(inputStr As String) As String
    Dim i As Integer
    Dim result As String
    
    ' 逐个字符检查，只保留数字
    For i = 1 To Len(inputStr)
        If IsNumeric(Mid(inputStr, i, 1)) Then
            result = result & Mid(inputStr, i, 1)
        End If
    Next i
    
    ExtractNumbers = result
End Function

第二步：在存入字典时应用函数 #

现在你可以在读取数据并添加到字典的地方，直接调用这些函数处理内容。举几个具体场景的例子：

场景1：提取Change Number的倒数第2个单词 #

假设你的Change Number单元格内容是"Change number: CHG-7890"，你想要提取CHG-7890（倒数第2个单词）：

If InStr(1, SearchString, "Change number") Then
    ' 用GetLastNthWord处理后再存入字典
    chNum = GetLastNthWord(datasheet.Cells(i, 1), 2)
    ' 额外加个判断，避免重复键报错
    If Not ChangeNumbers.Exists(chNum) Then
        ChangeNumbers.Add chNum, New Dictionary
    End If
End If

场景2：提取Priority中的纯数字 #

如果Priority单元格内容是"Priority: 2 Medium"，你只想保留数字2：

If InStr(1, datasheet.Cells(i + j, 2), "Priority") Then
    Dim processedPriority As String
    processedPriority = ExtractNumbers(datasheet.Cells(i + j, 2))
    ChangeNumbers.Item(chNum).Item(chSub).Item(rptNum).Add 4, processedPriority
End If

场景3：提取Change Subject的倒数第3个单词 #

假设Change Subject是"Change subject: Update Billing System Module"，要提取倒数第3个单词Billing：

ElseIf InStr(1, SearchString, "Change subject") Then
    chSub = GetLastNthWord(datasheet.Cells(i, 1), 3)
    ChangeNumbers.Item(chNum).Add chSub, New Dictionary
End If

第三步：调试技巧 #

如果处理结果不符合预期，可以在函数里加Debug.Print输出中间结果，方便排查：

Function GetLastNthWord(inputStr As String, n As Integer) As String
    Dim wordArray() As String
    wordArray = Split(Trim(inputStr), " ")
    
    Debug.Print "Original string: " & inputStr
    Debug.Print "Split into " & UBound(wordArray) + 1 & " words"
    
    If UBound(wordArray) + 1 >= n Then
        GetLastNthWord = wordArray(UBound(wordArray) - n + 1)
        Debug.Print "Extracted word: " & GetLastNthWord
    Else
        GetLastNthWord = inputStr
        Debug.Print "Not enough words, returning original"
    End If
End Function

打开VBA的“立即窗口”（Ctrl+G）就能看到这些输出。

为什么不推荐存入字典后修改？ #

你的字典是四层嵌套的（ChangeNumbers -> chNum -> chSub -> rptNum -> 列号:值），后续修改需要遍历每一层的键，不仅代码写起来繁琐，还容易因为键不存在、数据类型不匹配等问题报错。而在存入前处理数据，逻辑更直接，也更容易调试。

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