Copy Rows to Columns Other Sheet

Question

I have a table with headings Name, Date, Number, gender.

I need to export to another sheet.
"Name", "Date", "Number" and gender" in "A".
Values below in "B".

For example:

Old sheet

Name	Date	Number	gender
John	01.01.01	7382	male
Peter	01,02,02	6482	male

How is should look like in other sheet:

A	B
Name	John
Date	01.01.01
Number	7382
gender	male
Name	Peter
Date	01.02.02,
Number	6482
gender	male

I made a macro but I'm not able to make it full auto for the whole document.

Sub Makro7()
'
' Makro7 Makro
'
'
    Range("A1:O1,A2:O2").Select
    Range("A2").Activate
    Selection.Copy
    Sheets("Export").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("Exportieren").Select
    Range("A1:O1,A3:O3").Select
    Range("A3").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Export").Select
    Range("A16").Select
    Range("A16").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

Answer 1

Transform Data

Sub TransformData()

    ' Define constants.
    
    Const SRC_NAME As String = "Exportieren"
    Const SRC_COLUMNS_COUNT As Long = 4
    
    Const DST_NAME As String = "Export"
    Const DST_FIRST_CELL_ADDRESS As String = "A3"
    Const DST_EMPTY_ROWS_COUNT As Long = 1
    Const DST_COLUMNS_COUNT As Long = 2 ' don't change!
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Read: copy the values from the source worksheet to the source arrays.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SRC_NAME)
    Dim srg As Range
    Set srg = sws.Range("A1").CurrentRegion.Resize(, SRC_COLUMNS_COUNT)
    
    Dim hData() As Variant: hData = srg.Rows(1).Value ' source headers
    Dim srCount As Long: srCount = srg.Rows.Count - 1 ' don't count headers
    Dim sData() As Variant: sData = srg.Resize(srCount).Offset(1) ' source data
    
    ' Modify: copy the values from the source arrays to the destination array.
    
    ' Calculate the number of destination rows.
    Dim drCount As Long: drCount = srCount * SRC_COLUMNS_COUNT
    drCount = drCount + (srCount - 1) * DST_EMPTY_ROWS_COUNT
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To DST_COLUMNS_COUNT)
    
    Dim sr As Long, sc As Long, dr As Long, dc As Long
    
    For sr = 1 To srCount
        For sc = 1 To SRC_COLUMNS_COUNT
            dr = dr + 1
            For dc = 1 To DST_COLUMNS_COUNT
                Select Case dc
                    Case 1: dData(dr, dc) = hData(1, sc) ' header
                    Case 2: dData(dr, dc) = sData(sr, sc) ' data
                End Select
            Next dc
        Next sc
        dr = dr + DST_EMPTY_ROWS_COUNT
    Next sr
    
    Erase sData
    Erase hData
    
    ' Write: copy the values from the destination array to destination range.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DST_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(drCount, DST_COLUMNS_COUNT)
    
    ' Write the values to the destination worksheet.
    drg.Value = dData
    ' Clear below (if old data).
    drg.Resize(dws.Rows.Count - drg.Row - drCount + 1).Offset(drCount).Clear
    
    ' Inform.
    
    MsgBox "Data tranformed.", vbInformation

End Sub

Additional Information

• If you want to get the results you initially asked for, in one column, you need to make only three changes:

  Const DST_COLUMNS_COUNT As Long = 1 ' don't change!
  

  remove , dc As Long

  and instead of the For dc = 1... Next dc loop, use:

  dData(dr, 1) = hData(1, sc) & "=" & sData(sr, sc)