Using scripting dictionary to add contiguous group of items from non contiguous range

[stnkynts]

This one has me stumped.

See attached workbook:
Using a dictionary I would like to copy the values in Sheet1 column C to Sheet 2 column A based upon the contiguous groups of strings in Sheet1 column A. I.E. Sheet1 C1 will be copied to Sheet2 A1, Sheet1 C7:C9 will be transposed to Sheet2 A2:C2, etc. (See sheet2 for results)

Note: I know many other ways of doing this, I am specifically looking to see if this is possible using a dictionary.

Code I have so far

Sub Dictionary_Test()
Dim ws1 As Worksheet:    Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet:    Set ws2 = Sheets("Sheet2")
Dim r As Range
Dim dict As Object
Dim i As Long
Dim it

Set dict = CreateObject("Scripting.Dictionary")
i = 1

With dict
    For Each r In ws1.Range("A2:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
        '// The second if in the below line is to account for single string in group and the third if is to bypass the rest of the group
        If Not Len(r) = 0 And Not Len(r.Offset(1, 0)) = 0 And Not Len(r.Offset(-1)) = 0 Then
            '// Add item to dictionary: key is i, item is range
            On Error GoTo Err1
            Set .Items(i) = r.Resize(r.End(xlDown).Row - r.Row, 1)  'FIRST ERROR IS HERE: 424 Object Required
            i = i + 1
            Debug.Print r.Address
        Else
            'Specify for single string in group
        End If
    Next r
    
    '// My thoughts on how I would proceed
    For Each it In .Keys
        ws2.Range("A" & Rows.Count).End(3)(2) = Application.Transpose(.Keys(it))
    Next it
End With

Exit Sub
Err1:
Debug.Print Err.Number & " " & Err.Description

End Sub

If you need any other information please let me know. Thank you.

[WHER]

Try this version to see if it gets the result you're looking for:

Sub Dictionary_Test()
Dim ws1 As Worksheet:    Set ws1 = Sheets("Sheet1")
Dim ws2 As Worksheet:    Set ws2 = Sheets("Sheet2")
Dim r As Range, myArea As Range, myClInArea As Range
Dim dict As Object
Dim i As Long
Dim it

Set dict = CreateObject("Scripting.Dictionary")
i = 1

With dict
Set r = ws1.Range("A2:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeConstants)
    
    For Each myArea In r.Areas
         For Each myClInArea In myArea
           .Item(i) = .Item(i) & "|" & myClInArea.Offset(0, 2).Value2
         Next myClInArea
         .Item(i) = Mid(.Item(i), 2)
         i = i + 1
    Next myArea
    For Each it In .Keys
    .Item(it) = Split(.Item(it), "|")
        ws2.Range("A" & Rows.Count).End(3)(2).Resize(1, UBound(.Item(it)) + 1) = .Item(it)
    Next it
End With

Exit Sub
Err1:
Debug.Print Err.Number & " " & Err.Description

End Sub

[kalak]

I find post#1 somewhat puzzling.
As noted, there's various ways to produce the result.
There's also various ways to use one or more of the properties of the dictionary object.
All of the things a dictionary can do can be done in other ways. Dictionary is often more convenient and sometimes faster. It's neither of these in the example you give.
There's a code below including a dictionary but making no use of it because its unclear which of its properties are important to you. If you'd like to be more specific about which dictionary properties you want there should be little problem in including them, but for what purpose?

Sub stuff()
Dim dict As Object: Set dict = CreateObject("scripting.dictionary")
Dim s&, c&, u(), r&, i&
Sheets("sheet1").Activate
s = Application.CountA(Columns(3))
c = 1
ReDim u(1 To s, 1 To c)
For Each a In Columns(1).SpecialCells(2).Areas
    Set a = a.Offset(, 2)
    r = r + 1
    If a.Rows.Count > c Then c = a.Rows.Count: ReDim Preserve u(1 To s, 1 To c)
    If r > 1 Then For i = 1 To a.Rows.Count: u(r - 1, i) = a(i, 1): Next i
Next a
Sheets("sheet2").Range("A1").Resize(r, c) = u
End Sub

[stnkynts]

Thank you WHER. Exactly what I was looking for.