Extracting cell contents based on the string within the cell using dictionaries - vba

Question

I am quite new to VBA and was looking through stackoverflow. I found a neat VBA macro that utilizes Dictionaries and seemed like it could be applied to my problem also. However, after editing the macro I can't seem to make it work like I mean to.
My data is as follows: In column A I have Review numbers, Review topics and Analysis numbers. These follow a structure where Review number is 1st, then 2 rows later there is Review topic and under Review topic can be multiple Analysis numbers but the 1st one is 2 rows below the Review topic. In column B there are details about the reviewed item. I am interested in 3 different ones(height, weight and price). There is sometimes extra details here which is why I use string-matching (InStr). Sometimes there are less details. In general the data does not have a specific enough form to rely on the amount of rows between specific groups of data.
Data looks generally like this: https://imgur.com/a/QcdrMcR
The goal is to move extract the contents of the cells containing Review number, Review topic, Analysis number, Height, Weight and Price. These should be in separate cells on the same row. In case of multiple analysis, the following analysis should be below the row containing the 1st analysis and height, weight and price following this like before. Review number and topic dont need to be duplicated.
In the code I use dictionaries and a whole lotta ElseIfs. As I said, this is largely taken from another post. It works fine if I try to find the 1st analysis detail but when I try to find all 3 it stops working altogether giving me error 424 object required on the 2 last ElseIfs in the 1st loop. Moreover, the part that mostly works (finding the detailA which is height) only works if the searched string is found on the cell one row below the current row. In other words, it only works if the height/detailA is on row 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
I am also open to any other improvements. My logic seems very heavy but I couldn't get it working even to this degree with any of the other ways (tried using more loops and less if-structures).
I plan on trimming the contents of the cells to only include the numbers but this is a worry for the future. I already have made working excel formulas for this.