Copy Transpose Paste Vertically Breaking on Blanks - arrays

Question

I am new to VBA and coding in general and I am being tasked with some coding that is proving difficult. I am trying to copy/transpose/paste values from a two-column PivotTable and I need it to paste vertically on another sheet and break on blanks. (see image) I need to copy each group in the PivotTable then transpose paste values vertically on a new worksheet. I believe I need to count populated rows (using an array?) until I get to a blank row then paste the group. I can picture what I need to do but all my coding attempts are way off. Except for the copy/paste, I have no clue how to code this. I cannot figure out how to capture each group of populated rows to be pasted.
' Copy a vertical range (on "FQNID_Sites" sheet) and paste to a horizontal range in column B (next blank row on "BH_FH" sheet)
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("FQNID_Sites")
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("BH_FH")
Dim cellToPasteTo As Range
' Need to loop through each group breaking on each siteNFID in column D (or break on blanks in column E?)
Set rng = Range("$D$2:$E$" & ActiveSheet.UsedRange.Rows.Count)
For Each cell In rng
Set cellToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Offset(1, 0)
If cell.Value = "" And Not IsNull(copyStart) Then
copyEnd = cell.Offset(-1, 0).Address
ElseIf cell.Value = "" Then
copyStart = cell.Offset(0, -1).Address
End If
If Not IsNull(copyStart) And Not IsNull(copyEnd) Then
sourceSheet.Range(copyStart & ":" & copyEnd).Select
Selection.Copy
cellToPasteTo.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
End If
Next cell
Application.CutCopyMode = False
I need it to break on each siteNFID/FQNID then paste values for each group vertically in column B on the BH_FH worksheet.
Example of the input and expected output format

Answer 1

This code will work. Tested on similar data structure. I used the code sheet name in the code `Sheet1'. Change as needed.
Option Explicit
Sub runTranspose()
With Sheet1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
'load range starts to transpose
Dim i As Long
For i = 2 To lastRow
If Len(.Cells(i, 5)) = 0 Then
Dim startTranspose As Range
If startTranspose Is Nothing Then
Set startTranspose = .Cells(i, 5)
Else
Set startTranspose = Union(startTranspose, .Cells(i, 5))
End If
End If
Next
Dim c As Range
For Each c In startTranspose
transposeData c
Next
End With
End Sub
Sub transposeData(r As Range)
With Sheet1
Dim nextRow As Long
nextRow = .Cells(.Rows.Count, 8).End(xlUp).Row + 1
Dim fullRange As Range
Set fullRange = Range(r.Offset(1, -1), r.Offset(1).End(xlDown))
Dim arr As Variant
arr = fullRange.Value
.Cells(nextRow,7).Value = r.offset(-1).Value 'to add label
.Cells(nextRow, 8).Resize(2, UBound(arr)).Value = Application.Transpose(arr)
End With
End Sub