轉換多列表並將 output go 轉換為兩列？

Question

我正在尋找是否可以從示例圖像中的表中獲取數據和標題，並將 output go 分為兩列，第一列是重復的 header？ 我確實嘗試過轉置，但是 email 行一直填充到 E 列。

Answer 1

請嘗試下一種方法。 它使用 arrays 即使在大范圍內也很快，主要在 memory 中工作。它從“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”（“電子郵件”標題）開始，並且在最后一個 header（第一行）之后沒有任何其他記錄...

Answer 2

轉置數據

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

Answer 3

如果我理解正確的話

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

請注意，代碼必須在工作表包含活動數據的地方運行。