I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.

CodePudding user response：

Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":

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

The code can be easily adapted to return anywhere (another sheet, workbook, range etc).

The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...

CodePudding user response：

Transpose Data

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, sr As Long
    
    For Each srrg In srg.Rows
        sr = sr   1
        If sr > 1 Then
            srg.Rows(1).Copy
            dfCell.PasteSpecial Transpose:=True
            srg.Rows(sr).Copy
            dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
            Set dfCell = dfCell.Offset(drOffset)
        'Else ' it's the first row; do nothing
        End If
    Next srrg

    Application.ScreenUpdating = True

    MsgBox "Data transposed.", vbInformation

End Sub

CodePudding user response：

If I understand you correctly

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

Please note, the code must be run where the sheet contains the data is active.