overworking code, infinite running

  • Thread starter Thread starter ksnapp
  • Start date Start date
K

ksnapp

Hello there,

I modified some code so that it will find cells in column A that ar
not blank, then add a new row above it and fill a cell with some text


The problem is simple

It finds a filled cell in column A inserns a new row and some text the
looks at the next row down (the same one it say in the first step) an
adds another row with the text and so on and so on and so on.


I tried to add a fix I could think of but not it just runs from the to
of the a column to the end + 25 rows.

here is the code with my current not-fix:

Sub DeletingStuffinA() ' deletes topcrop in the report
Range("A3").Select '
Do Until X = 25 'Change number for extra number of blanks between data
CaseText = activecell.Value
Select Case (CaseText)

Case Is <> ""
selection.EntireRow.Insert
activecell.Offset(-1, 4) = "TOTAL TRANSACTIONS"
activecell.Offset(2, -4).Select
Y = 1

End Select
If Y = 1 Then
Else
activecell.Offset(1, 0).Select
End If
If activecell = "" Then
X = X + 1
Else
X = 0
End If
Y = 0
Loop
End Su
 
Hello
Try this

Sub DeletingStuffinA() ' deletes topcrop in the report
Range("A3").Select '
Do Until ActiveCell.Row = 25 'Change number for extra
number of blanks between data
If ActiveCell.Text <> "" Then
Selection.EntireRow.Insert
ActiveCell.Offset(-1, 4) = "TOTAL TRANSACTIONS"
ActiveCell.Offset(2, 0).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub


THIS VERSION ONLY ADDS A BLANK ROW IF YOU NEED IT.

Sub DeletingStuffinA() ' deletes topcrop in the report
Range("A3").Select '
Do Until ActiveCell.Row = 25 'Change number for extra
number of blanks between data
If ActiveCell.Text <> "" Then
If ActiveCell.Offset(-1, 0) <> "" Then 'only inserts a
blank row if you need a blank row
Selection.EntireRow.Insert
ActiveCell.Offset(0, 4) = "TOTAL TRANSACTIONS"
ActiveCell.Offset(2, 0).Select
Else
ActiveCell.Offset(-1, 4) = "TOTAL TRANSACTIONS"
ActiveCell.Offset(1, 0).Select
End If
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub


James
 
Is this what you want?

Sub DeletingStuffInA()
Dim i As Integer, X As Integer
i = 1: X = 0
Do Until X = 25
If Cells(i, 1) <> "" Then
Cells(i, 5) = "Total Transactions"
Cells(i, 1).EntireRow.Insert
i = i + 2
Else
X = X + 1
i = i + 1
End If
Loop
End Sub

Regards,
Greg
 
Back
Top