使用词典基于单元格内的字符串提取单元格内容

Question

我对VBA很新，正在查看stackoverflow。我找到了一个利用字典的整洁的VBA宏，似乎它也可以应用于我的问题。但是，在编辑宏之后，我似乎无法像我的意思那样工作。

我的数据如下：在A栏中，我有评论编号，评论主题和分析编号。这些遵循一个结构，其中审阅编号为第1，然后是2行之后有审查主题，在审查主题下可以是多个分析编号，但第一个是审阅主题下方的2行。在B栏中有关于审查项目的详细信息。我对3种不同的（高度，重量和价格）感兴趣。这里有时候有额外的细节，这就是我使用字符串匹配（InStr）的原因。有时细节较少。通常，数据没有足够的特定形式来依赖特定数据组之间的行数。

数据通常如下所示：https://imgur.com/a/QcdrMcR

目标是移动提取包含评论编号，评论主题，分析编号，高度，重量和价格的单元格的内容。这些应该位于同一行的单独单元格中。在多次分析的情况下，以下分析应该在包含第一次分析的行的下方，以及之后的高度，重量和价格。审核编号和主题不需要重复。

在代码中我使用字典和整个很多ElseIfs。正如我所说，这主要来自另一篇文章。如果我试图找到第一个分析细节，但是当我试图找到所有3个时它完全停止工作，并且在第一个循环中的最后两个ElseIfs上需要错误424对象，它工作正常。此外，主要工作的部分（找到高度的detailA）仅在搜索的字符串在当前行下面一行的单元格上找到时才有效。换句话说，它仅在高度/细节A位于第i + 1行

时有效

Sub FindData()

    Dim datasheet As Worksheet
    Dim reportsheet As Worksheet

    Dim SearchString As String
    Dim SearchString2 As String

    Dim i As Integer

    Set datasheet = Sheet1
    Set reportsheet = Sheet2

    Dim chNum As String
    Dim chSub As String
    Dim analysisNum As String
    Dim detailA As String
    Dim detailB As String
    Dim detailC As String
    Dim ReviewCollection As New Dictionary

    Dim dictKey1 As Variant
    Dim dictKey2 As Variant
    Dim dictKey3 As Variant
    Dim dictKey4 As Variant
    Dim dictKey5 As Variant
    Dim dictKey6 As Variant

    reportsheet.Range("A1:H200").ClearContents
    finalrow = datasheet.Cells(datasheet.Rows.Count, 1).End(xlUp).Row

    For i = 1 To finalrow
        SearchString = datasheet.Range("A" & i)
        SearchString2 = datasheet.Range("B" & i)

        If InStr(1, SearchString, "Review number") Then
            chNum = datasheet.Cells(i, 1)
            ReviewCollection.Add chNum, New Dictionary 'For review numbers
        ElseIf InStr(1, SearchString, "Review topic") Then
            chSub = datasheet.Cells(i, 1)
            ReviewCollection.Item(chNum).Add chSub, New Dictionary 'For review topics
        ElseIf InStr(1, SearchString, "Analysis number") Then
            analysisNum = datasheet.Cells(i, 1)
            ReviewCollection.Item(chNum).Item(chSub).Add analysisNum, New Dictionary 'For Analysis numbers
        ElseIf InStr(1, SearchString2, "Height") Then
            detailA = datasheet.Cells(i, 2)
            ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Add detailA, New Dictionary 'For Analysis detail #1
        'ElseIf InStr(1, SearchString2, "Weight") Then
        '    detailB = datasheet.Cells(i, 2)
        '    ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Item(detailA).Add detailB, New Dictionary 'For Analysis detail #2
        'ElseIf InStr(1, SearchString2, "Price") Then
        '    detailA = datasheet.Cells(i, 2)
        '    ReviewCollection.Item(chNum).Item(chSub).Item(analysisNum).Item(detailA).Item(detailB).Add detailC, New Dictionary 'For Analysis detail #3
        End If
    Next i

'Loop to print out the dictionary
    i = 1
    For Each dictKey1 In ReviewCollection.Keys
        reportsheet.Cells(i, 1) = dictKey1 'Review number

        If ReviewCollection.Item(dictKey1).Count > 0 Then
            For Each dictKey2 In ReviewCollection.Item(dictKey1).Keys
                reportsheet.Cells(i, 2) = dictKey2 'Review topic

                If ReviewCollection.Item(dictKey1).Item(dictKey2).Count > 0 Then
                    For Each dictKey3 In ReviewCollection.Item(dictKey1).Item(dictKey2).Keys 'Report Number
                        reportsheet.Cells(i, 3) = dictKey3
                        If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Count > 0 Then
                            For Each dictKey4 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Keys 'Analysis detail #1
                                reportsheet.Cells(i, 4) = dictKey4
                                'START of the printing for the problematic area
                                If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Count > 0 Then
                                    For Each dictKey5 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Keys 'Analysis detail #2
                                    reportsheet.Cells(i, 5) = dictKey5
                                        If ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Item(dictKey5).Count > 0 Then
                                            For Each dictKey6 In ReviewCollection.Item(dictKey1).Item(dictKey2).Item(dictKey3).Item(dictKey4).Item(dictKey5).Keys 'Analysis detail #3
                                                reportsheet.Cells(i, 6) = dictKey6
                                            Next dictKey6
                                        Else
                                            i = i + 1 'no reports, so moves down to prevent overwriting change number
                                        End If
                                    Next dictKey5
                                Else
                                    i = i + 1 'no reports, so moves down to prevent overwriting change number
                                End If
                                'END of the problematic area
                            Next dictKey4
                        Else
                            i = i + 1 'no reports, so moves down to prevent overwriting change number
                        End If
                    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

我也对任何其他改进持开放态度。我的逻辑看起来非常沉重，但我无法通过任何其他方式使其工作（尝试使用更多循环和更少的if结构）。

我计划修剪单元格的内容以仅包含数字，但这是对未来的担忧。我已经为此制作了excel公式。