Macro to copy previous row and insert two blank rows

[dd]

Hi,
I'm working on a excel sheet that contains about 6000 rows of data.
What I need to do is to look at column A and go through the rows and
whenever the row has the text "Total Spend" I need to copy it to the
following row with "Total N Spend" and insert two blank rows after
that. So for example:

Column A
Row 1 Apple
Row 2 IBM
Row 3 Dell
Row 4 Total Spend - Computer
Row 5 (Would copy row 4) Total N Spend - Computer
Row 6 Insert Blank Row
Row 7 Insert Blank Row
Row8 CarA
Row9 CarB
Row10 Total Spend - Cars
Row11 Total N Spend - Cars
Row12 Insert Blank Row
etc.


Previously someone helped me with this code below but nothing happens
after I run this macro.
Any help is appreciated, Thank you.


Sub TotalSpend()


Dim iCount As Integer
Dim iMax As Integer
Dim iLength As Integer


iCount = 1
iMax = WorksheetFunction.CountA(Sheets("Sheet1").Columns(1))


Do Until Left(Sheets("Sheet1").Cells(iCount, 1).Value, 11) = "Total
Spend -"
iCount = iCount + 1
Select Case iCount
Case Is > iMax
MsgBox "Some data must be missing in Column A of Sheet1."
Exit Sub
End Select
Loop


iLength = Len(Sheets("Sheet1").Cells(iCount, 1).Value)


Sheets("Sheet1").Cells(iCount + 1, 1).Value = "Total N Spend - " & _
Right(Sheets("Sheet1").Cells(iCount, 1).Value, iLength - 14)


End Sub

 

[Guest]

Try this modified macro on a copy of your workbook

Sub TotalSpendSub()

Dim myRange As Range
Dim r As Range
Dim InsertVal As Boolean

Set myRange = Sheets("Sheet1").Cells(1, 1)
lrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set myRange = myRange.Resize(lrow, 1)

InsertVal = True

For Each r In myRange
Debug.Print r.Value
If Len(r.Value) > 0 Then
If r.Value Like "Total*" Then
If InsertVal Then
InsertVal = False
r.Offset(1, 0).EntireRow.Insert
r.Offset(1, 0).EntireRow.Value = r.EntireRow.Value
r.Offset(2, 0).EntireRow.Insert
r.Offset(3, 0).EntireRow.Insert
Else
InsertVal = True
End If
End If
End If
Next r
End Sub