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

 

[Jameo]

its running slow because you are selecting each cell, which you don't need to do. Trying something along the lines of this:

Sub test()
Dim StRng As Range
Dim LCol As Long
Dim my As Long


'not sure why you need my?


my = 8


LCol = Cells(2, Columns.Count).End(xlToLeft).Column

'sets the start range of the cell
Set StRng = Range(Cells(1, 15), Cells(1, 6 + my))

'Cycles through each column to the last filled column, you can get rid of Lcol and just use a number instead
For i = 1 To LCol

'test if the cell is empty
    If StRng.Value = "" Then
     'do nothing
    Else
        'rest of code here
        StRng.Offset(0, 1).Interior.colour = RGB(147, 197, 112)
    End If




Next


LRow = Range("A" & Rows.Count).end(xlUp).Row


Set StRng = StRng.Offset(LRow, 0)
StRng.Value = ""
StRng.Interior.Color = RGB(147, 197, 114)


With StRng.Offset(0, 1)
.Value = ""
.Interior.Color = RGB()


End With

 

[Fluff]

What is the first cell you want to check & how many rows do you want to skip?

 

[Dibug]

Thank you, Jameo. I'm not sure of you understand what I am trying to do. I need to select every 8th row, take the value from 4 cells (A-D), change the colour of those for cells then paste the value of the active cells into the last row, in cells (A - D), insert "QA" after the value of A and then colour those for cells as well.

I will try your suggestion, somehow but it doesn't make sense to me how it will loop through.

 

[Dibug]

Hi Fluff. Starting at row 14, then selecting every 8th row.

 

[Fluff]

Ok, how about

Sub QACheck()
   Dim i As Long
   
   For i = 14 To Range("A" & Rows.Count).End(xlUp).Row Step 8
      If InStr(1, Range("A" & i), "QA", vbTextCompare) = 0 Then
         With Range("A" & i).Resize(, 4)
            .Interior.Color = RGB(147, 197, 114)
            .Copy Range("A" & Rows.Count).End(xlUp).Offset(1)
         End With
         With Range("A" & Rows.Count).End(xlUp)
            .Value = .Value & "QA"
         End With
      End If
   Next i
End Sub

 

[Dibug]

Thank you, Fluff.
Code looks good; I will try it. But that looks like it only does CellA. To expand to cells B, C, D & E, do I expand the code within the If statemet to also include these rows?

 

[Dibug]

But that code looks really tidy !

 

[Fluff]

At the moment it does A:D to do A:E make this change

With Range("A" & i).Resize(, [COLOR=#ff0000]5[/COLOR])

 

[Dibug]

Wow!!!! That works perfectly! Such a very precise code...I would have never come up with that!

Thank you so much, Fluff!