Transpose static range in a loop

Question

I've tried to transpose a static range from column A on sheet 1 to rows on sheet 3 in a loop, to no avail. Here is the code I'm using so far:

Sub Looptranspose()
'
' Looptranspose Macro
'
' Keyboard Shortcut: Ctrl+a

    Dim x As Integer
    Dim y As Integer
    x = 1
    y = x + 18
    Range("A" & CStr(x) & ":A" & CStr(y)).Select
    Selection.Copy
    Sheets("Sheet3").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    x = x + 19
End Sub

How do I loop this until row A is complete? This code transposes the selected 1st range of 19 cells in column A into a selected row on Sheet 3.

I need macro to select next 19 cells in row A on sheet one and transpose into next row on sheet 3. Here's the example:

Excel Step 1 https://drive.google.com/file/d/0B2TQdtpfUIa5OUpRTWNwLUQ5WVk/edit?usp=sharing

Excel Step 2 https://drive.google.com/file/d/0B2TQdtpfUIa5TkNrVXRwOHh2TFk/edit?usp=sharing

How can I continue selecting following 19 cells in row A Sheet 1 (until there is no more data) and transposing to following row in sheet 3?

Answer 1

Looking at your code and the screen shots, I think you want to take a long column A in one sheet, and transpose it in 19-cell chunks into another sheet.

The problem is - you don't actually include a loop, and you don't update the location of the destination. I tried fixing those things in my example. If that is not what you wanted, please leave a comment.

Note - typically using .Select will make your code slow, hard to read, and prone to errors. It is better to create objects that reference specific ranges.

Sub copyChunk()
' copy chunks of 19 cells from column A of sheet 1
' and paste their transpose on sheet 3
' starting in the first row

Dim sh1 As Worksheet, sh2 As Worksheet
Dim r1 As Range, r2 As Range
Dim chunk As Integer
chunk = 19

Set sh1 = ActiveWorkbook.Sheets("sheet1")
Set sh2 = ActiveWorkbook.Sheets("sheet3")

' picking the starting point here - this could be "anywhere"
Set r1 = Range(sh1.Cells(1, 1), sh1.Cells(chunk, 1))
Set r2 = sh2.[A1]

While Application.WorksheetFunction.CountA(r1) > 0
  r1.Copy
  r2.PasteSpecial Paste:=xlPasteAll, SkipBlanks:=False, Transpose:=True
  ' move down "chunk" cells for the source
  Set r1 = r1.Offset(chunk, 0)
  ' move down one row for the destination
  Set r2 = r2.Offset(1, 0)
Wend

End Sub