Извлечение содержимого ячейки на основе строки внутри ячейки с использованием словарей

Question

Я новичок в VBA и просматривал stackoverflow.Я нашел аккуратный макрос VBA, который использует словари и, кажется, его можно применить и к моей проблеме.Однако после редактирования макроса я не могу заставить его работать так, как я хотел.

Мои данные выглядят следующим образом: В столбце AI есть номера обзора, темы обзора и номера анализа.Они следуют структуре, где номер обзора равен 1-му, затем через 2 строки появляется тема обзора, а в разделе «Обзор» может быть несколько номеров анализа, но 1-й номер находится на 2 строки ниже темы обзора.В колонке B есть подробности о проверенном товаре.Я заинтересован в 3 разных (рост, вес и цена).Здесь иногда есть дополнительные подробности, поэтому я использую сопоставление строк (InStr).Иногда деталей меньше.Как правило, данные не имеют достаточно конкретной формы, чтобы полагаться на количество строк между конкретными группами данных.

Данные в целом выглядят так: https://imgur.com/a/QcdrMcR

Цель состоит в том, чтобы переместитьизвлечь содержимое ячеек, содержащих номер обзора, тему обзора, номер анализа, рост, вес и цену.Они должны быть в отдельных ячейках в одном ряду.В случае многократного анализа, следующий анализ должен быть ниже строки, содержащей 1-й анализ и рост, вес и цену, следующие за этим, как прежде.Номер отзыва и тему не нужно дублировать.

В коде я использую словари и целый лот ElseIfs.Как я уже сказал, это во многом взято из другого поста.Это прекрасно работает, если я пытаюсь найти 1-ю деталь анализа, но когда я пытаюсь найти все 3, она перестает работать вообще, давая мне объект ошибки 424, необходимый для 2 последних ElseIfs в 1-м цикле.Более того, та часть, которая в основном работает (нахождение 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 для этого.