Copy Rows to Other Sheet-CodePudding

i have a Table with Name, Date, Number, gender. below are the values. i just need to export them to another file. the headline with "Name, Date, Number, gernder.below are the values" needs to be in "A",every value which needs to be in "B"

for example:

Sub OldSheet()
 Name, Date, Number, gender.
John,01.01.01, 7382, male
peter,01,02,02, 6482. male
 End Sub()

This is how is should look like in Sheet nr 2:

Sub NewSheet()
Name, John,
Date, 01.01.01, 
Number,7382, 
gender.male

Name, peter,
Date, 01.02.02, 
Number,6482, 
gender.male

End Sub()

i made a macro but im not able to make it full auto for the whole dokument.

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

thank you very much for your time

I tried my best, but i not that talented<3

CodePudding user response：

try this one:

Sub Test()

    Dim wb As Workbook
    Dim wsRead As Worksheet
    Dim wsWrite As Worksheet
    Dim readRng As Range
    Dim row As Range, startCell As Range
    
    ReDim arr(0, 0) As Variant
    Set wb = ThisWorkbook
    Set wsRead = wb.Sheets(1)
    Set wsWrite = wb.Sheets("Export")
    
    Set readRng = wsRead.UsedRange 'or set a specific Range like so wsRead.Range("A1:D1500")
    
    nRows = readRng.Rows.Count
    nColumns = readRng.Columns.Count
    
    ReDim arr(1 To nRows, 1 To nColumns)
    For nr = 1 To nRows
        For nc = 1 To nColumns
            
            arr(nr, nc) = readRng.Cells(nr, nc).Value2
            
        Next
    Next
    
    Set startCell = wsWrite.Range("A1")
    
    For nr = 2 To nRows
        For nc = 1 To nColumns
            pr = (nr - 2) * 5
            pc = nc - 1
            startCell.Offset(pr   pc, 0).Value = arr(1, nc)
            startCell.Offset(pr   pc, 1).Value = arr(nr, nc)
        Next
    Next

End Sub

CodePudding user response：

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