Restructure data

[bran8989]

I have this code, where I first insert a row on every 15th row, in effort to break apart my data. I then want to to cut what is in rows 2 to 14, and paste to row 1. Then I want to delete the now empty rows 2 to 14, and I want the process to start over (where it now uses row 2 as the pasting row for what is in rows 3 to 15), etc. etc.

Any ideas on the modifications I can make, sorry new to VBA..


Sub insertro()


Dim r As Long, lr As Long
lr = Range("A" & rows.Count).End(xlUp).Row + 100000
For r = 15 To lr Step 15
rows(r).Insert Shift:=xlDown
Next r

i = 1
n = 2
lastrow = ActiveSheet.Cells(rows.Count, 1).End(xlUp).Row


For n = 2 To lastrow


With ActiveSheet
.Range("A" & n, Range("A" & n).End(xlToRight)).Cut .Range("A" & i).End(xlToRight).Offset(, 1)


End With


Next n

End Sub

 

[Macropod]

Try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, lRow As Long, OutRow As Long, c As Long, lCol As Long, OutCol As Long
With ThisWorkbook.Worksheets("Sheet1")
  lRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
  OutRow = 1: OutCol = .Range("A1").End(xlToRight).Column
  For r = 2 To lRow
    If r Mod 15 = 0 Then
      OutRow = OutRow + 1: OutCol = 0
    End If
    lCol = .Cells(r, 1).End(xlToRight).Column
    For c = 1 To lCol
      OutCol = OutCol + 1
      .Cells(OutRow, OutCol).Value = .Cells(r, c).Value
    Next
  Next
  .Rows(OutRow + (OutCol <> 0) & ":" & lRow).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub

 

[bran8989]

Try something along the lines of:

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, lRow As Long, OutRow As Long, c As Long, lCol As Long, OutCol As Long
With ThisWorkbook.Worksheets("Sheet1")
  lRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
  OutRow = 1: OutCol = .Range("A1").End(xlToRight).Column
  For r = 2 To lRow
    If r Mod 15 = 0 Then
      OutRow = OutRow + 1: OutCol = 0
    End If
    lCol = .Cells(r, 1).End(xlToRight).Column
    For c = 1 To lCol
      OutCol = OutCol + 1
      .Cells(OutRow, OutCol).Value = .Cells(r, c).Value
    Next
  Next
  .Rows(OutRow + (OutCol <> 0) & ":" & lRow).EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub

Unfortunately this doesnt do anything.. It's calculating in the background, but not completing anything.

 

[Macropod]

It worked on some test data I constructed in line with the implications of what you described. If, as you say, it's not working, you might need to change:
ThisWorkbook.Worksheets("Sheet1")
to:
ActiveSheet
and, if it still doesn't work, you'll need to give a better description of your data layout (e.g. by posting a representative screenshot here, for which, see Posting Aids in the Forum Guidelines: https://www.mrexcel.com/forum/board-announcements/127080-guidelines-forum-use.html).