excel vba I need to transpose data from columns to rows - vba

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