Transposing rows in first sheet into a single column in second sheet until end of data in first sheet

[dportnoy]

Hi. I am very new to VBA code and this loop crashed Excel several times for me.

I am attempting to transpose data from the range D2:K2 (which is in rows) in the "GoogleFormData" sheet to cell E22 in the "TheModel" sheet until it reaches a cell range Di:Kj with no data.

Right now, the data looks like this (this is data in columns D through K in the "GoogleFormData" sheet):

And I would like it to look like this (this is data is in column E in the "TheModel" sheet starting with E22 as the top cell):

This is the code I have attempted below.

Sub TransposeModules()
    
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    
    i = 1
    j = 1
    k = 14
    
    Do Until IsEmpty(Worksheets("GoogleFormData").Range("D" & i & ":K" & j))
        
        i = i + 1
        j = j + 1
        k = k + 8
        
        Sheets("GoogleFormData").Select
        Range("D" & i & ":K" & j).Select
        Selection.Copy
        Sheets("TheModel").Select
        Range("E" & k).Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
        
    Loop


End Sub

 

[Trebor76]

Hi dportnoy,

Welcome to MrExcel!!

See how this goes:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim lngRowTo As Long, lngRow As Long, lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    Set wsFrom = ThisWorkbook.Sheets("GoogleFormData")
    Set wsTo = ThisWorkbook.Sheets("TheModel")
    
    lngRowTo = wsFrom.Range("D:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngRow = 2 To lngRowTo
        lngPasteRow = IIf(lngPasteRow = 0, 22, wsTo.Cells(Rows.Count, "E").End(xlUp).Row + 1)
        wsFrom.Range("D" & lngRow & ":K" & lngRow).Copy
        wsTo.Range("E" & lngPasteRow).PasteSpecial Transpose:=True
    Next lngRow
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub

Regards,

Robert

 

[dportnoy]

Hi dportnoy,

Welcome to MrExcel!!

See how this goes:

Option Explicit
Sub Macro1()

    Dim wsFrom As Worksheet, wsTo As Worksheet
    Dim lngRowTo As Long, lngRow As Long, lngPasteRow As Long
   
    Application.ScreenUpdating = False
   
    Set wsFrom = ThisWorkbook.Sheets("GoogleFormData")
    Set wsTo = ThisWorkbook.Sheets("TheModel")
   
    lngRowTo = wsFrom.Range("D:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngRow = 2 To lngRowTo
        lngPasteRow = IIf(lngPasteRow = 0, 22, wsTo.Cells(Rows.Count, "E").End(xlUp).Row + 1)
        wsFrom.Range("D" & lngRow & ":K" & lngRow).Copy
        wsTo.Range("E" & lngPasteRow).PasteSpecial Transpose:=True
    Next lngRow
   
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
   
End Sub

Regards,

Robert

Thank you so much!!!!! It worked perfectly

 

[Trebor76]

Thank you so much!!!!! It worked perfectly

Thanks for letting us know and you're welcome

 

[bebo021999]

One way:

Option Explicit
Sub test()
Dim rng As Range, cell As Range, arr(), k&
Set rng = Range("D2").CurrentRegion
ReDim arr(1 To rng.Count, 1 To 1)
    For Each cell In rng
        k = k + 1
        arr(k, 1) = cell.Value
    Next
Range("E22").Resize(k).Value = arr
End Sub