Cut and paste 65,500 rows with data

[Victor Per]

I would like to appeal to your knowledge of Excel VBA. I've been trying to solve this problem for some time now.
I have a 'source' worksheet with over 65,500 rows that I want to 'cut' into individual records and then paste to the 'output' worksheet. Each record contains the contents of 13 rows.
Can anyone help me with the correct VBA code for this problem? Thanks in advance!

 

[Herakles]

I would like to appeal to your knowledge of Excel VBA. I've been trying to solve this problem for some time now.
I have a 'source' worksheet with over 65,500 rows that I want to 'cut' into individual records and then paste to the 'output' worksheet. Each record contains the contents of 13 rows.
Can anyone help me with the correct VBA code for this problem? Thanks in advance!

Welcome to MrExcel.

Try this on a copy of your data.

Paste this code into a standard code module.

Private Sub subCreateRecord()
Dim i As Long
Dim rng As Range
Dim lngRow As Long
Dim WsSource As Worksheet
Dim WsOutput As Worksheet
Dim lngRecord As Long

    ActiveWorkbook.Save
    
    Set WsSource = Worksheets("Source")
    
    Set WsOutput = Worksheets("Output")
    
    WsOutput.Cells.ClearContents
    
    WsOutput.Range("A1").Value = "Record Number"
    
    With WsOutput.Range("B1:N1")
        .Formula = "=" & Chr(34) & "Content0" & Chr(34) & " & COLUMN()-1"
        .Value = .Value
    End With
    
    Set rng = WsSource.Range("B2:B14")
        
    lngRow = 2
    
    lngRecord = 1
    
    For i = 2 To 65501 Step 13
        WsOutput.Cells(lngRow, 1).Value = lngRecord
        lngRecord = lngRecord + 1
        WsOutput.Cells(lngRow, 2).Resize(1, 13).Value = WorksheetFunction.Transpose(rng)
        Set rng = rng.Offset(13, 0)
        lngRow = lngRow + 1
    Next i
    
    With WsOutput.Range("A1").CurrentRegion
        .RowHeight = 30
        .VerticalAlignment = xlCenter
        .IndentLevel = 1
        .EntireColumn.AutoFit
    End With
    
    ActiveWorkbook.Save
    
    MsgBox lngRecord - 1 & " records created.", vbOKOnly, "Confirmation"
    
End Sub

 

[kvsrinivasamurthy]

Try.

Sub TranposeData()
Dim A, Lr&, Ta&, Tb&, Ro&, X&, Y&

Lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("A2:A" & Lr)
X = 1 + Int(UBound(A, 1) / 13)
ReDim B(1 To X, 1 To 14)

For Ta = 1 To Lr - 1 Step 13
Ro = Ro + 1
B(Ro, 1) = "Record No " & Ro
    For Tb = 2 To 14
    If Ta + Tb - 2 > (Lr - 1) Then Exit For
    B(Ro, Tb) = A(Ta + Tb - 2, 1)
    Next Tb
Next Ta

Sheets("Sheet2").Range("A2").Resize(X, 14) = B
End Sub

 

[kvsrinivasamurthy]

With headers also.

Sub TranposeData()
Dim A, Lr&, Ta&, Tb&, Ro&, X&, Y&
Dim head(0 To 13)
head(0) = "Record Number"
Lr = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
A = Sheets("Sheet1").Range("A2:A" & Lr)
X = 1 + Int(UBound(A, 1) / 13)
ReDim B(1 To X, 1 To 14)

For Ta = 1 To Lr - 1 Step 13
Ro = Ro + 1
B(Ro, 1) = "Record No " & Ro
    For Tb = 2 To 14
    If Ta + Tb - 2 > (Lr - 1) Then Exit For
    B(Ro, Tb) = A(Ta + Tb - 2, 1)
    Next Tb
Next Ta

With Sheets("Sheet2")
.Range("A1").CurrentRegion.Offset(1, 0).Clear
.Range("A2").Resize(X, 14) = B
.Range("A1:N1") = Array("Record Number", "Content 01", "Content 02", "Content 03", "Content 04", "Content 05", "Content 06", "Content 07", "Content 08", "Content 0", "Content 10", "Content 11", "Content 12", "Content 13")
End With
End Sub

 

[Victor Per]

Many, many thanks for your help @Herakles and @kvsrinivasamurthy. You have really helped me out! I've changed some bits and am developing a steep learning curve in VBA.