请尝试下一种方法。它使用数组，即使在大范围内也是快速的，主要是在内存中工作。它从“F2”开始返回。它能够处理“状态”之后您（可能）需要的任何其他列：

Sub TransposeMails()
 Dim sh As Worksheet, lastR As Long, lastCol As Long
 Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
 
 Set sh = ActiveSheet 'use here the necessary sheet
 lastR = sh.Range("A" & sh.rows.count).End(xlUp).row          'last row
 lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column 
 arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
 arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2       'place the range to be processed (except headers) in an array for faster iteration/processing
 ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
                                                             '+ 1 for the empty rows in between...

 For i = 1 To UBound(arr)
    For j = 1 To UBound(arrH)
        k = k + 1
        arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
    Next j
    k = k + 1 'for the empty row between groups...
 Next i
 
 'drop the processed array content:
 sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub

该代码可以很容易地适应返回任何地方（另一个工作表，工作簿，范围等）。
要处理的范围必须从“A1”（“电子邮件”标题）开始，并且在最后一个标题之后没有任何其他记录（在第一行）...

转置数据

Sub TransposeData()
    
    Const SRC_NAME As String = "Sheet1"
    Const DST_NAME As String = "Sheet1"
    Const DST_FIRST_CELL As String = "A8"
    Const EMPTY_COLS As Long = 0
    Const EMPTY_ROWS As Long = 1
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
    Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range, shrg As Range
    Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
    
    For Each srrg In srg.Rows
        If Not IsHeaderReady Then
            srrg.Copy
            dfCell.PasteSpecial Transpose:=True
            Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
            IsHeaderReady = True
        Else ' header is ready; it's already copied for the first data row
            If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
            srrg.Copy
            dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
            Set dfCell = dfCell.Offset(drOffset)
        End If
    Next srrg

    Application.ScreenUpdating = True

    MsgBox "Data transposed.", vbInformation

End Sub

如果我没理解错

Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range

'loop to each range with data  as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)

    For i = 1 To cnt
        Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
                                        .Resize(rg.Columns.Count, 1)
        rslt.Value = Application.Transpose(rg)
        rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
    Next
End Sub

请注意，代码必须在包含数据的工作表处于活动状态时运行。