Help with VBA code

[Dibug]

Hello all you VBA gods! I am new to this forum and new to VBA as well. I am trying to code a spreadsheet for work and, of course, I have bitten off more than I can chew but on the upside, I am learning quite a bit about VBA!

I have this tricky problem.... I am trying to select every 'nth' cell value (and change the interior colour of that active cell) and interpose those values in the last row and change the interior colour too. (Fortunately, column A contains no formulas).
This code sort of works but when it pastes values in the last row it seems to offset by 14 row (6 + my ??) and then doubles it for the next one in the sequence. What am I doing wrong? (I know, it is a bit long winded but, as I stated, my VBA coding skills are novice at best!)

Here is the code I am using:

Private Sub CommandButton6_Click()
'QA Repeats'
Dim my As Integer, ur As Integer
Dim i As Long
On Error GoTo Getout
ur = 1
my = 8
Application.ScreenUpdating = False
If my = 0 Or ur = 0 Then Exit Sub
On Error GoTo Getout
Range("A15:A" & 6 + my).Select  'I think this is the line giving me the trouble'
Do While ActiveCell.Value <> ""


sn = ActiveCell.Offset(0, 0).Value
si = ActiveCell.Offset(0, 1).Value
wn = ActiveCell.Offset(0, 2).Value
td = ActiveCell.Offset(0, 3).Value
bd = ActiveCell.Offset(0, 4).Value


If InStr(ActiveCell.Value, "QA") > 0 Then GoTo Getout 'This part excludes inserted rows with 'QA' in them'


ActiveCell.Offset(0, 0).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 1).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 2).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 3).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 4).Interior.Color = RGB(147, 197, 114)




Application.ScreenUpdating = False


i = Range("A" & Rows.Count).End(xlUp).Row
ActiveCell.Offset(i, 0).Value = sn & "QA"   'insertion of suffix QA to value sn'
ActiveCell.Offset(i, 1).Value = si
ActiveCell.Offset(i, 2).Value = wn
ActiveCell.Offset(i, 3).Value = td
ActiveCell.Offset(i, 4).Value = bd
ActiveCell.Offset(i, 0).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 1).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 2).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 3).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 4).Interior.Color = RGB(147, 197, 114)
Dim ws As Worksheet
Dim lastRow As Long




On Error Resume Next




ActiveCell.Offset(1 + my + ur - 1, 0).Select
Loop


Getout:
Application.ScreenUpdating = True


End Sub


However, I can get it to work by inserting a blank row deletion into the code and it works...like this:

Private Sub CommandButton6_Click()
'QA Repeats'
Dim my As Integer, ur As Integer
Dim i As Long
On Error GoTo Getout
ur = 1
my = 8
Application.ScreenUpdating = False
If my = 0 Or ur = 0 Then Exit Sub
On Error GoTo Getout
Range("A15:A" & 6 + my).Select
Do While ActiveCell.Value <> ""


sn = ActiveCell.Offset(0, 0).Value
si = ActiveCell.Offset(0, 1).Value
wn = ActiveCell.Offset(0, 2).Value
td = ActiveCell.Offset(0, 3).Value
bd = ActiveCell.Offset(0, 4).Value


If InStr(ActiveCell.Value, "QA") > 0 Then GoTo Getout


ActiveCell.Offset(0, 0).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 1).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 2).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 3).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(0, 4).Interior.Color = RGB(147, 197, 114)




Application.ScreenUpdating = False


i = Range("A" & Rows.Count).End(xlUp).Row
ActiveCell.Offset(i, 0).Value = sn & "QA"
ActiveCell.Offset(i, 1).Value = si
ActiveCell.Offset(i, 2).Value = wn
ActiveCell.Offset(i, 3).Value = td
ActiveCell.Offset(i, 4).Value = bd
ActiveCell.Offset(i, 0).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 1).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 2).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 3).Interior.Color = RGB(147, 197, 114)
ActiveCell.Offset(i, 4).Interior.Color = RGB(147, 197, 114)
Dim ws As Worksheet
Dim lastRow As Long


Set ws = ActiveSheet
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row    'This seems to fix the issue but...'
With ws.Range("A10:A" & lastRow)                                       'takes a long time to run...a bit clunky'
    If WorksheetFunction.CountBlank(.Cells) > 0 Then
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
End With




On Error Resume Next




ActiveCell.Offset(1 + my + ur - 1, 0).Select
Loop


Getout:
Application.ScreenUpdating = True


End Sub

It all works (with the downside of deleting many, many rows) but it is long winded and when running through 100's to 1000's of rows the code takes a while to complete.

Is there a way I can run this smoother and quicker?
Any help would be greatly appreciated!

Many thanks... Dibug

 

[Fluff]

Glad to help & thanks for the feedback

 

[Dibug]

Hi Fluff.

I just wanted to say thank you so much for your advice. It has really taught me heaps on perfecting code. I had another code that was so slow and rather awkward (like the one in the post).

Private Sub CommandButton4_Click()
'Quartz Blanks'


Dim my As Integer, ur As Integer
On Error GoTo Getout
ur = 1
my = 9
Application.ScreenUpdating = False
If my = 0 Or ur = 0 Then Exit Sub
On Error GoTo Getout
Range("A10:A" & 3 + my).Select
Do While ActiveCell.Value <> ""
5 Range(ActiveCell, ActiveCell.Offset(ur - 1, 0)).EntireRow.Insert
xs = Range("A9:A9")
ActiveCell.Offset(0, 0).Value = xs
xr = ActiveCell.Row
xn = xr / 10
ActiveCell.Offset(0, 1).Value = "Quartz Blank - " & xn
xc = Range("C9:C9")
ActiveCell.Offset(0, 2).Value = xc
ActiveCell.Offset(0, 0).Interior.Color = RGB(253, 253, 150)
ActiveCell.Offset(0, 1).Interior.Color = RGB(253, 253, 150)
ActiveCell.Offset(0, 2).Interior.Color = RGB(253, 253, 150)
ActiveCell.Offset(0, 3).Interior.Color = RGB(253, 253, 150)
ActiveCell.Offset(0, 4).Interior.Color = RGB(253, 253, 150)
ActiveCell.Offset(1 + my + ur - 1, 0).Select
Loop
Getout:
Application.ScreenUpdating = True
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Range("BF9:BL" & LastRow).FillDown
End Sub



But now, with your help on the previous one, I was able to re-write the code using a For loop instead:

Private Sub CommandButton6_Click()
'QB2'


sn = Range("A10:A10")
bn = Range("C10:C10")


For i = 11 To 10000 Step 11
If Range("A" & i).Value = "" Then
GoTo Getout
End If
If Range("A" & i).Value <> "" Then
Rows(i).Insert
End If
With Range("A" & i).Resize(, 5)
.Interior.Color = RGB(253, 253, 150)
End With
With Range("A" & i).Offset(0, 0)
.Value = sn
End With
With Range("A" & i).Offset(0, 1)
qn = i / 11
.Value = "Quartz Blank - " & qn
End With
With Range("A" & i).Offset(0, 2)
.Value = bn
End With
Next i

Getout:
LastRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Range("BF10:BL" & LastRow).FillDown
End Sub

It runs sooooo much faster. Thank you for extending my VBA knowledge!
Many regards,

Dibug