Do Until Loop in VBA with IF Statement - Help Needed

dtarockoff

New Member
Joined
Jun 26, 2013
Messages
24
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
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

Well-known Member
Joined
Mar 13, 2010
Messages
523
Try this
Code:
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

New Member
Joined
Jun 26, 2013
Messages
24
@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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
... 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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
42,298
Office Version
365
Platform
Windows
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
Rich (BB code):
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

Well-known Member
Joined
Sep 19, 2005
Messages
5,112
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:

Code:
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
 
Last edited:

dtarockoff

New Member
Joined
Jun 26, 2013
Messages
24
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:

Code:
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!
 

Forum statistics

Threads
1,082,343
Messages
5,364,794
Members
400,815
Latest member
gangstar67

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top