Do Until Loop in VBA with IF Statement - Help Needed

[dtarockoff]

Hi,

I'm currently working on a project in VBA where I need to write a sub that changes the font of the text in Column A for a given row based on meeting certain conditions. I've attached a picture of the worksheet I'm working with to make this easier to understand:

In column A, starting at A2 and down, I have a bunch of regions named Region#. In Columns B:M I have sales data for each month of the year for each particular region. What I want to do is write a Do Until Loop that checks each region's quarterly sales (Jan-March, April-June, July-Sept, and Oct-Dec) to see if there's a consistent upward or downward trend, and changes the font color of the region name in column A if it meets one of the conditions. If, for a given region, the quarterly sales consistently increase, I want the region name to be changed to red. For example, if the sum of cells B2:D2<E2:G2<H2:J2<K2:M2, I would change the font of cell A2 red. If they consistently decrease, I want the name to be blue. For example, if the sum of cells B2:D2>E2:G2>H2:J2>K2:M2, I would change the font of cell A2 blue. If there isn't a consistent trend, I just want the name to stay black. I need this code to work regardless of how many regions are added.

I've come up with an idea of how to write this but I'm having a lot of difficulty. This is what I'm currently trying (and it's clearly not working):

Dim TQ1 As Single
Dim TQ2 As Single
Dim TQ3 As Single
Dim TQ4 As Single
Dim i As Integer


i = 0


TQ1 = Range("B2").Offset(i, 0).Value + Range("C2").Offset(i, 0).Value + Range("D2").Offset(i, 0).Value
TQ2 = Range("E2").Offset(i, 0).Value + Range("F2").Offset(i, 0).Value + Range("G2").Offset(i, 0).Value
TQ3 = Range("H2").Offset(i, 0).Value + Range("I2").Offset(i, 0).Value + Range("J2").Offset(i, 0).Value
TQ4 = Range("K2").Offset(i, 0).Value + Range("L2").Offset(i, 0).Value + Range("M2").Offset(i, 0).Value


Do Until Range("A2").Offset(i, 0).Value = ""
TQ1 = Range("B2").Offset(i, 0).Value + Range("C2").Offset(i, 0).Value + Range("D2").Offset(i, 0).Value
TQ2 = Range("E2").Offset(i, 0).Value + Range("F2").Offset(i, 0).Value + Range("G2").Offset(i, 0).Value
TQ3 = Range("H2").Offset(i, 0).Value + Range("I2").Offset(i, 0).Value + Range("J2").Offset(i, 0).Value
TQ4 = Range("K2").Offset(i, 0).Value + Range("L2").Offset(i, 0).Value + Range("M2").Offset(i, 0).Value

If TQ1 < TQ2 < TQ3 < TQ4 Then
Range("A2").Offset(i, 0).Font.Color = vbRed
i = i + 1


ElseIf TQ4 < TQ3 < TQ2 < TQ1 Then
Range("A2").Offset(i, 0).Font.Color = vbBlue
i = i + 1


Else
Range("A2").Offset(i, 0).Font.Color = vbBlack
i = i + 1

End If
Loop


End Sub


I'd really appreciate any help - I'm pretty sure it's not working because the variables TQ1-TQ4 aren't resetting when the loop runs, but I don't know how to make it work. Thanks!

 

[Peter_SSs]

The problem with the supplied picture is that it cannot be copied to a worksheet to test and to re-create the data manually is a lot of typing.
Have you tried any of the methods in my signature block for showing small screen shots? 15-20 rows should be plenty.

Also, does it have to be vba?
If it could be achieved with Excel's standard Conditional Formatting, would that be acceptable?

 

[djreiswig]

Try this

Sub test()
    With ThisWorkbook.Sheets("Sheet1")
        Dim LastRow As Long
        Dim TQ1 As Single, TQ2 As Single, TQ3 As Single, TQ4 As Single
        Dim i As Long
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        
        For i = 2 To LastRow
            TQ1 = Range("B" & i).Value + Range("C" & i).Value + Range("D" & i).Value
            TQ2 = Range("E" & i).Value + Range("F" & i).Value + Range("G" & i).Value
            TQ3 = Range("H" & i).Value + Range("I" & i).Value + Range("J" & i).Value
            TQ4 = Range("K" & i).Value + Range("L" & i).Value + Range("M" & i).Value
            
            If TQ1 < TQ2 And TQ2 < TQ3 And TQ3 < TQ4 Then
                Range("A" & i).Font.Color = vbRed
            ElseIf TQ4 < TQ3 And TQ3 < TQ2 And TQ2 < TQ1 Then
                Range("A" & i).Font.Color = vbBlue
            Else
                Range("A" & i).Font.Color = vbBlack
            End If
        Next i
    End With
End Sub

 

[dtarockoff]

@Peter_SSs I haven't tried any of the methods in your signature block but I could send you the actual file if you need that to test things out. I do want to figure it out in VBA though since I'm trying to write in VBA as much as possible to learn it better.

@djreiswig I just tried that and it got me closer to what I've been able to do but still isn't doing what I want. Your code just changed the font color of the region names in column A red for rows 5 and 14 (Regions 4 & 13). I may be able to mess around with that code though and see if I can tweak it to work. Thanks for the start.

 

[Peter_SSs]

... but I could send you the actual file if you need that to test things out.

Since this is a public forum, we try to keep as much of the information & conversation as possible in the public arena.
Related points are 18 & 19 of the Posting Guidelines and #7 of the Forum Rules.

 

[Peter_SSs]

I do want to figure it out in VBA though since I'm trying to write in VBA as much as possible to learn it better.

It could still be done with vba and without looping through each row. Try this

Sub ApplyFormat()
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=AND(SUM(K2:M2)>SUM(H2:J2),SUM(H2:J2)>SUM(E2:G2),SUM(E2:G2)>SUM(B2:D2))"
    .FormatConditions(1).Font.Color = vbRed
    .FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=AND(SUM(K2:M2)<SUM(H2:J2),SUM(H2:J2)<SUM(E2:G2),SUM(E2:G2)<SUM(B2:D2))"
    .FormatConditions(2).Font.Color = vbBlue
  End With
End Sub

 

[sheetspread]

Your code just changed the font color of the region names in column A red for rows 5 and 14 (Regions 4 & 13)

I thought you wanted that too??? Well blue instead of red perhaps for regions with consistently increasing quarterly sales, the opposite (which you don't seem to have here) in red, this code also does that:

Sub colortrend1()
Dim i%, j%
Dim qgroup(2) As Variant
Dim colorarr As Variant
colorarr = Array(3, 1, 5)
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 3
qgroup(j - 1) = Sgn(Evaluate("=sum(" & Range("E" & i).Offset(, (j * 3) - 3).Resize(, 3).Address & ")-sum(" & Range("B" & i).Offset(, (j * 3) - 3).Resize(, 3).Address & ")"))
Next j
Range("A" & i).Font.ColorIndex = colorarr(WorksheetFunction.RoundDown(WorksheetFunction.Average(qgroup), 0) + 1)
Next i
End Sub

 

[dtarockoff]

I thought you wanted that too??? Well blue instead of red perhaps for regions with consistently increasing quarterly sales, the opposite (which you don't seem to have here) in red, this code also does that:

Sub colortrend1()
Dim i%, j%
Dim qgroup(2) As Variant
Dim colorarr As Variant
colorarr = Array(3, 1, 5)
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To 3
qgroup(j - 1) = Sgn(Evaluate("=sum(" & Range("E" & i).Offset(, (j * 3) - 3).Resize(, 3).Address & ")-sum(" & Range("B" & i).Offset(, (j * 3) - 3).Resize(, 3).Address & ")"))
Next j
Range("A" & i).Font.ColorIndex = colorarr(WorksheetFunction.RoundDown(WorksheetFunction.Average(qgroup), 0) + 1)
Next i
End Sub

Hey sorry, you're right and that original code actually worked. I was surprised because I expected more of the data to meet that trend but it was only those two rows.

Thanks for all of the help!