excel vba I need to transpose data from columns to rows

Question

I am looking for a VBA solution to transform data from a scenario similar to the illustration below. From Sheet1 copy first three cell values (A3,B3,C3) only if there is a value in any cell to the left of them (D3,E3,...) in Sheet2 past first 3 cell values (A2,B2,C2), and the first cell after that with a value (D3) and also copy the header value into the adjacent cell. Any additional values to the left get the same treatment and become the next row, again copying (A3,B3,C3). Then the next adjacent cell value (E3) along with the header value into the adjacent cell. Then move down to the next row in Sheet1 where there are values after the first 3 cells until it has looped all the way through sheet1 to produce the example in Sheet2.

I have searched for other similar solutions but cannot find anything that works. This is the closest I've found with minor edits on my part but doesn’t work, any help is greatly appreciated.

Sub Sample()
Dim wsThis As Worksheet
Dim wsThat As Worksheet
Dim ThisAr As Variant
Dim ThatAr As Variant
Dim Lrow As Long
Dim Col As Long
Dim i As Long
Dim k As Long

Set wsThis = Sheet1: Set wsThat = Sheet2

With wsThis
    '~~> Find Last Row in Col A
    Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
    '~~> Find total value in D,E,F so that we can define output array
    Col = Application.WorksheetFunction.CountA(.Range("C2:G" & Lrow))

    '~~> Store the values from the range in an array
    ThisAr = .Range("A2:G" & Lrow).Value

    '~~> Define your new array
    ReDim ThatAr(1 To Col, 1 To 7)

    '~~> Loop through the array and store values in new array
    For i = LBound(ThisAr) To UBound(ThisAr)
        k = k + 1

        ThatAr(k, 1) = ThisAr(i, 1)
        ThatAr(k, 2) = ThisAr(i, 2)
        ThatAr(k, 3) = ThisAr(i, 3)

        '~~> Check for Color 1
        If ThisAr(i, 5) <> "" Then 'ThatAr(k, 4) = ThisAr(i, 4)
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 4) = ThisAr(i, 4)
            ThatAr(k, 5) = ThisAr(i, 5)
        End If

        '~~> Check for Color 2
        If ThisAr(i, 7) <> "" Then
            k = k + 1
            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)
            ThatAr(k, 6) = ThisAr(i, 6)
            ThatAr(k, 7) = ThisAr(i, 7)
        End If

        '~~> Check for Color 3
        'If ThisAr(i, 6) <> "" Then
            'k = k + 1
            'ThatAr(k, 1) = ThisAr(i, 1)
            'ThatAr(k, 2) = ThisAr(i, 2)
            'ThatAr(k, 3) = ThisAr(i, 3)
            'ThatAr(k, 4) = ThisAr(i, 6)
        'End If
    Next i
End With

'~~> Create headers in Sheet2
Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value

'~~> Output the array
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub

Answer 1

Using a variant array(dynamic array) is simple and fast.

Sub test()
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim vDB As Variant, vR() As Variant
    Dim r As Long, i As Long, n As Long
    Dim c As Integer, j As Integer, k As Integer

    Set wsThis = Sheet1: Set wsThat = Sheet2

    vDB = wsThis.Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)

    For i = 2 To r
        For j = 4 To c
            If vDB(i, j) <> "" Then
                n = n + 1
                ReDim Preserve vR(1 To 5, 1 To n)
                For k = 1 To 3
                    vR(k, n) = vDB(i, k)
                Next k
                vR(4, n) = vDB(i, j)
                vR(5, n) = vDB(1, j)
            End If
        Next j
    Next i
    With wsThat
        .UsedRange.Clear
        .Range("a1").Resize(1, 3) = wsThis.Range("a1").Resize(1, 3).Value
        .Range("d1").Resize(1, 2) = Array("Value", "ID#")
        .Range("a2").Resize(n, 5) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 2

Sorry, I'm not sure why I couldn't open your attached images. But you might want to try this code:

Change this line:
wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
To
wsThat.Range("A2").Resize(4, Col).Value = WorksheetFunction.Transpose(ThatAr)

Hope this help