Newbie - How to make this Macro repeat until is over and how do I make it delete the rows which value is Zero

[CaiusZaid]

Hello, I have this Macro and I need it to repeat until there are no more lines. the tricky part is that the macro creates 6 new rows each time. also how can I make it delete the rows with zero balance?

thank you

Sub Create_Rows()
'
' Create_Rows Macro
'
' Keyboard Shortcut: Ctrl+q
'
ActiveCell.Rows("1:1").EntireRow.Select
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(-1, 0).Range("A1:C1").Select
Selection.Copy
ActiveCell.Offset(1, 0).Range("A1:C6").Select
ActiveSheet.Paste
ActiveCell.Offset(0, 3).Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "7701.1"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "7600"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "9010"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "7620"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "7600"
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveCell.FormulaR1C1 = "7600"
ActiveCell.Offset(-6, 0).Range("A1").Select
Selection.Cut
ActiveCell.Offset(1, 1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-1, 0).Range("A1").Select
Selection.Cut
ActiveCell.Offset(2, 0).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-2, 1).Range("A1").Select
Selection.Cut
ActiveCell.Offset(3, -1).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-3, 2).Range("A1").Select
Selection.Cut
ActiveCell.Offset(4, -2).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-4, 3).Range("A1").Select
Selection.Cut
ActiveCell.Offset(5, -3).Range("A1").Select
ActiveSheet.Paste
ActiveCell.Offset(-5, 4).Range("A1").Select
Selection.Cut
ActiveCell.Offset(6, -4).Range("A1").Select
ActiveSheet.Paste





End Sub

 

[Fluff]

Hi & welcome to MrExcel
How about

Sub Create_Rows()
   Dim i As Long
   
   For i = Range("A" & Rows.count).End(xlUp).Row To 2 Step -1
      With Range("A" & i)
         .Offset(1).Resize(6).EntireRow.Insert
         .Resize(7, 3).FillDown
         .Offset(1, 3).Resize(6).Value = Application.Transpose(Array("7701.1", "7600", "9010", "7620", "7600", "7600"))
         .Offset(1, 4).Resize(6).Value = Application.Transpose(.Offset(, 3).Resize(, 6).Value)
         .ClearContents
      End With
   Next i
   Range("A:A").SpecialCells(xlBlanks).EntireRow.delete
End Sub

 

[CaiusZaid]

Thank you,
it still not deleting the rows where Cell E equals to zero or are empty

thanks again for your time.

 

[Fluff]

That's because you never said to do that

Does the rest of it do what you need?

 

[CaiusZaid]

yes, the rest is perfect

 

[CaiusZaid]

i added

Range("E:E").SpecialCells(xlBlanks).EntireRow.Delete at the end to delete the empty ones but not sure how to make it delete the ones with a zero

 

[Fluff]

Try

Sub Create_Rows()
   Dim i As Long
   
   For i = Range("A" & Rows.count).End(xlUp).Row To 2 Step -1
      With Range("A" & i)
         .Offset(1).Resize(6).EntireRow.Insert
         .Resize(7, 3).FillDown
         .Offset(1, 3).Resize(6).Value = Application.Transpose(Array("7701.1", "7600", "9010", "7620", "7600", "7600"))
         .Offset(1, 4).Resize(6).Value = Application.Transpose(.Offset(, 3).Resize(, 6).Value)
         .ClearContents
      End With
   Next i
   With Range("E2", Range("E" & Rows.count).End(xlUp))
      .Replace 0, "", xlWhole, , , , False, False
      On Error Resume Next
      .SpecialCells(xlBlanks).EntireRow.Delete
      Range("A:A").SpecialCells(xlBlanks).EntireRow.Delete
      On Error GoTo 0
   End With
End Sub

 

[CaiusZaid]

Thank you very Much, it worked like a charm

 

[Fluff]

Glad to help & thanks for the feedback