Code to stack by row first rather than by column?

[MeghanES]

Hello
I have the follow VBA code which stacks all of column A on top of column B and so on. What I need it to do now is stack all of row 1 on top of row 2 etc.

So rather than having:
A1
A2
A3
B1
B2
B3... etc.

It would instead be:
A1
B1
A2
B2
A3
B3... etc.

Any help would be appreciated, thank you inadvance!

Sub Stack_cols()
 
    Dim LastRow     As Long, LastColumn As Long
    Dim Col         As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
 
    On Error GoTo Stack_cols_Error:
 
    Do
        SendKeys "{END}"
        'Ask for a new sheet name
        sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
        'cancel pressed
        If StrPtr(sNewShtName) = 0 Then Exit Sub
      
        If Len(sNewShtName) > 0 Then
            'check if sheet exists
            If Not Evaluate("ISREF('" & sNewShtName & "'!A1)") Then
                'all ok
                Exit Do
            Else
                'inform user & try again
                MsgBox sNewShtName & Chr(10) & "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
            End If
        End If
    Loop
 
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
 
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Add a new worksheet, rename it and set it to a variable
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
    Set shtNew = Worksheets(sNewShtName)
 
    With shtOrg
        'Get the last column number in row 1
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For Col = 1 To LastColumn
            'Count the number of rows in the looping column
            LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
            'copy only cells with constant values
            .Range(.Cells(1, Col), .Cells(LastRow, Col)).SpecialCells(xlCellTypeConstants).Copy _
            Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + LastRow, 1))
            'count of the number of non blank rows in column
            lCountRows = lCountRows + Application.CountA(.Columns(Col))
        Next Col
    End With
 
Stack_cols_Error:
    'report errors
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
 
End Sub

 

[MeghanES]

Hello
I have the follow VBA code which stacks all of column A on top of column B and so on. What I need it to do now is stack all of row 1 on top of row 2 etc.

So rather than having:
A1
A2
A3
B1
B2
B3... etc.

It would instead be:
A1
B1
A2
B2
A3
B3... etc.

Any help would be appreciated, thank you inadvance!

Sub Stack_cols()
 
    Dim LastRow     As Long, LastColumn As Long
    Dim Col         As Long, lCountRows As Long
    Dim sNewShtName As String
    Dim shtOrg      As Worksheet, shtNew As Worksheet
 
    On Error GoTo Stack_cols_Error:
 
    Do
        SendKeys "{END}"
        'Ask for a new sheet name
        sNewShtName = InputBox("Enter the New worksheet name", "Enter name", "newsht")
        'cancel pressed
        If StrPtr(sNewShtName) = 0 Then Exit Sub
     
        If Len(sNewShtName) > 0 Then
            'check if sheet exists
            If Not Evaluate("ISREF('" & sNewShtName & "'!A1)") Then
                'all ok
                Exit Do
            Else
                'inform user & try again
                MsgBox sNewShtName & Chr(10) & "Worksheet name exists. Try again", vbInformation, "Sheet Exists"
            End If
        End If
    Loop
 
    'Set a sheet variable for the sheet where the data resides
    Set shtOrg = ActiveSheet
 
    'Turn off the screen update to make macro run faster
    Application.ScreenUpdating = False
    'Add a new worksheet, rename it and set it to a variable
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = sNewShtName
    Set shtNew = Worksheets(sNewShtName)
 
    With shtOrg
        'Get the last column number in row 1
        LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'Start a loop to copy and paste data from the first column to the last column
        For Col = 1 To LastColumn
            'Count the number of rows in the looping column
            LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
            'copy only cells with constant values
            .Range(.Cells(1, Col), .Cells(LastRow, Col)).SpecialCells(xlCellTypeConstants).Copy _
            Destination:=shtNew.Range(shtNew.Cells(lCountRows + 1, 1), shtNew.Cells(lCountRows + LastRow, 1))
            'count of the number of non blank rows in column
            lCountRows = lCountRows + Application.CountA(.Columns(Col))
        Next Col
    End With
 
Stack_cols_Error:
    'report errors
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
 
End Sub

This is a link to my previoes thread where I got help with this code - How do I get this code to skip blank cells?