Transposing in groups of rows

[gtslabs]

I am trying to transpose large groups of numbers from 1 sheet to
another.
I have data in sets of 78 rows. I want to get each 78 rows and put in
columns in second sheet
Can I get somehelp with my code? I get a application error 1004 error


Sub transposedata()
Dim source As Range
Dim destination As Range

For I = 1 To 130000 Step 78
source = Worksheets("data").Range(Cells(I, 6), Cells(I + 77, 6))
destination = Worksheets("Sheet1").Range(Cells(J, 2), Cells(J, 80))

Desination = source
J = J + 1
Next I

End Sub

 

[Sheeloo]

Try the macro below...

It will read column F (data sheet), 78 rows at a time and write to Col 2 of
Sheet1 after transposing the values...till you run out of rows in data sheet

Sub Transpose()
Dim srcSheet As String
Dim destSheet As String
Dim i, j, lastRow As Long

srcSheet = "Data"
destSheet = "Sheet1"

Worksheets(srcSheet).Activate

With Worksheets(srcSheet)
lastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
End With

lastRow = (lastRow / 78) - 1
j = 1

For i = 1 To lastRow
Worksheets(srcSheet).Range("F" & j & ":F" & (j + 77)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets(destSheet).Cells(i, 2).PasteSpecial Paste:=xlPasteAll,
Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
j = j + 78
Next i
End Sub

 

[Rick Rothstein]

Give this macro a try (where necessary, change my example assignments in the
Const statements to your actual conditions)...

Sub TransposeRange()
Dim R As Range
Dim LastUsedRow As Long

Const DataStartRow As Long = 6
Const TotalColumns As Long = 78
Const DataStartCol As String = "I"
Const SourceSheetName As String = "Data"
Const DestinationSheetName As String = "Sheet1"
Const DestinationCellAddress As String = "A1"

Set R = Worksheets(SourceSheetName).Columns("I").Resize(, TotalColumns)
LastUsedRow = R.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious).Row
R.Resize(LastUsedRow - DataStartRow + 1).Offset(DataStartRow - 1).Copy
With Worksheets(DestinationSheetName)
.Range(DestinationCellAddress).PasteSpecial Transpose:=True
Application.Goto .Range(DestinationCellAddress)
End With
Application.CutCopyMode = False
End Sub