PDA

View Full Version : Solved: Make sure numbers are increasing



InitialD
02-01-2011, 05:21 PM
Hi, I am a total new to VBA and would really appreciate if I can get some help.

I am trying to write a VBA code that goes through each row in the column to make sure the number is either increasing or decreasing.

For Ex:
Increasing
1
1
1
1

2
2
2
3
3
3
1


If Decreasing
10
10
10
10

7
7
6
3
3
3
5


It will continuously go through each row to make sure it's either the same or increasing, if it's blank it will keep the previous number and go to the next row. But if a number is decreasing it will stop and highlight the row with the decreasing number.

So basically it checks each row,
if the numbers start out decreasing, it will continue to decrease.
If the numbers start out increasing, it will continue to increase.

anandbohra
02-02-2011, 05:41 AM
Try this code.



Sub CheckRangeStatus()
Dim lastRow As Long, i As Long
Dim CheckforStatus As String
Dim ColtoCheck As String


ColtoCheck = "A" '<-- change to suit

i = 1 '<-- change to suit

With Sheet1 '<-- change to suit
lastRow = .Cells(.Rows.Count, ColtoCheck).End(xlUp).Row '<-- change to suit

If .Cells(i + 1, ColtoCheck).Value > .Cells(i, ColtoCheck) Then
CheckforStatus = "Increasing"
Else
CheckforStatus = "Decreasing"
End If

For i = 1 To lastRow

Select Case CheckforStatus
Case "Increasing"
If .Cells(i + 1, ColtoCheck).Value < .Cells(i, ColtoCheck) Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further
End If
Case "Decreasing"
If .Cells(i + 1, ColtoCheck).Value > .Cells(i, ColtoCheck) Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further

End If
End Select

Next i
End With
End Sub

InitialD
02-02-2011, 06:50 AM
Thanks anandbohra, you are a life saver!

But is it possible for it to also check for blanks and repetitive numbers.

For Ex:
Lets say the value for cell1 and cell2 are the same, it will take the value of cell2 as the new value, and then check to see if cell 3 is "blank" "increasing" or "decreasing".

Same for blanks.
If cell1 has a value, cell2 is blank, it will take the value for cell1, and then check the next cell, cell3. If cell3 is still blank, it will check cell4. If cell 4 has a value then it will do the check to see if it's the "same", "increasing", or "decreasing"

anandbohra
02-02-2011, 07:35 AM
Try this modified one

Sub CheckRangeStatus()
Dim lastRow As Long, i As Long
Dim CheckforStatus As String
Dim ColtoCheck As String
Dim CurrVal As Long '<-- change to suit as per your datatype
Dim NextVal As Long '<-- change to suit as per your datatype

ColtoCheck = "A" '<-- change to suit

i = 1 '<-- change to suit

With Sheet1 '<-- change to suit
lastRow = .Cells(.Rows.Count, ColtoCheck).End(xlUp).Row '<-- change to suit

If .Cells(i + 1, ColtoCheck).Value > .Cells(i, ColtoCheck) Then
CheckforStatus = "Increasing"
Else
CheckforStatus = "Decreasing"
End If

For i = 1 To lastRow
CurrVal = .Cells(i, ColtoCheck)
NextVal = .Cells(i + 1, ColtoCheck).Value

If NextVal = Empty Then NextVal = CurrVal

Select Case CheckforStatus
Case "Increasing"
If NextVal < CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further
End If
Case "Decreasing"
If NextVal > CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further

End If
End Select

Next i
End With
End Sub

InitialD
02-02-2011, 08:28 AM
Sorry, but still having the same problem for both the blanks, and repetitive numbers.

What I'm seeing right now is this:

blanks/empty
blanks/empty
1 <--- turned red
2
3
4
5

Same thing with repetitive numbers

1
1
1
2 <---turned red
2
3
4
5

anandbohra
02-02-2011, 08:49 AM
Try this
I applied your both example & found to be correct this time

Sub CheckRangeStatus()
Dim lastRow As Long, i As Long
Dim CheckforStatus As String
Dim ColtoCheck As String
Dim CurrVal As Long '<-- change to suit as per your datatype
Dim NextVal As Long '<-- change to suit as per your datatype

ColtoCheck = "A" '<-- change to suit

i = 1 '<-- change to suit

With Sheet1 '<-- change to suit
lastRow = .Cells(.Rows.Count, ColtoCheck).End(xlUp).Row

If .Cells(i + 1, ColtoCheck).Value >= .Cells(i, ColtoCheck) Then
CheckforStatus = "Increasing"
Else
CheckforStatus = "Decreasing"
End If

For i = 1 To lastRow
CurrVal = .Cells(i, ColtoCheck)
NextVal = .Cells(i + 1, ColtoCheck).Value

If NextVal = Empty Then NextVal = CurrVal

Select Case CheckforStatus
Case "Increasing"
If NextVal < CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further
End If
Case "Decreasing"
If NextVal > CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further

End If
End Select

Next i
End With
End Sub

InitialD
02-02-2011, 09:06 AM
Thank You So Much! It works perfectly with the increasing, but still have a problem with decreasing.

What I'm seeing:

blanks/empty
blanks/empty
10
10
10
9 <--turned to red
blanks/empty
8
6
5
10

anandbohra
02-02-2011, 09:20 AM
The reason for failure is at the time of initialization how does the system recognize whether its Increasing or Decreasing?:dunno
for that I used simple logic if 2nd is more than equal to first value then increasing or else decreasing

so that thing you have to keep in mind as first our logic should be strong what we want to achieve than only code works right.

in your first example you start with initial values that become base stone for logic.

Give me 5-6 concrete examples with what to highlight so that I will make sure you get what you want.

since its 9:45 PM in India, I am moving & will check your reply & example file tomorrow.

will give you code sometimes tomorrow.

Good Night

shrivallabha
02-02-2011, 10:15 AM
It will check for the first pattern and assume it to be correct. See if this is what you are looking for:
Sub OddManOut()
Dim TopRow As Long, LastRow As Long
Dim CurrVal As Integer, NextVal As Integer
'Find Top Most Filled Row
If Range("A1").Value = "" Then
TopRow = Range("A1").End(xlDown).Row
Else
TopRow = 1
End If
'Find Bottom Most Filled Row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Working out pattern
For i = TopRow To LastRow
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
Else
CurrVal = Range("A" & i).Value
If i = LastRow Then Exit Sub
i = Range("A" & i).End(xlDown).Row
NextVal = Range("A" & i + 1).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
End If
Next i
For i = TopRow To LastRow
Select Case Pattern
Case "Increasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal > NextVal Then
Range("A" & i + 1).Font.Color = vbRed
Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i + 1).Value
If CurrVal > NextVal Then
Range("A" & i + 1).Font.Color = vbRed
Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
End If
Case "Decreasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal < NextVal Then
Range("A" & i + 1).Font.Color = vbRed
Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i + 1).Value
If CurrVal < NextVal Then
Range("A" & i + 1).Font.Color = vbRed
Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
End If

End Select
Next i
End Sub

InitialD
02-02-2011, 11:14 AM
There's an error when I ran it. It says Run-time error, Method ' Range' of object '_Global' failed. It highlited line 84

InitialD
02-02-2011, 05:55 PM
The reason for failure is at the time of initialization how does the system recognize whether its Increasing or Decreasing?:dunno
for that I used simple logic if 2nd is more than equal to first value then increasing or else decreasing

so that thing you have to keep in mind as first our logic should be strong what we want to achieve than only code works right.

in your first example you start with initial values that become base stone for logic.

Give me 5-6 concrete examples with what to highlight so that I will make sure you get what you want.

since its 9:45 PM in India, I am moving & will check your reply & example file tomorrow.

will give you code sometimes tomorrow.

Good Night


So basically it runs like:
It checks to see whether it is increasing or decreasing.
If it's decreasing it does this
http://i1126.photobucket.com/albums/l601/Initial_D_1/Decreasing.jpg
http://s1126.photobucket.com/albums/l601/Initial_D_1/?action=view&current=Decreasing.jpg

Conversely if increasing, it does this
http://i1126.photobucket.com/albums/l601/Initial_D_1/increasing.jpg

anandbohra
02-03-2011, 01:49 AM
This code is tested on both the examples & gave me exact red highlighting as per your example.


Sub CheckRangeStatus()
Dim lastRow As Long, i As Long
Dim CheckforStatus As String
Dim ColtoCheck As String
Dim CurrVal As Long '<-- change to suit as per your datatype
Dim NextVal As Long '<-- change to suit as per your datatype

ColtoCheck = "A" '<-- change to suit

i = 1

With Sheet1 '<-- change to suit
lastRow = .Cells(.Rows.Count, ColtoCheck).End(xlUp).Row

' This loop logically determines the Staus for Increasing or Decreasing
For i = 1 To lastRow
CurrVal = .Cells(i, ColtoCheck)
NextVal = .Cells(i + 1, ColtoCheck).Value

If CurrVal <> Empty And NextVal <> Empty And CurrVal <> NextVal Then
If NextVal > CurrVal Then
CheckforStatus = "Increasing"
Else
CheckforStatus = "Decreasing"
End If

Exit For
End If

Next i

' This loop is for highlighting error values & skip if found one
For i = 1 To lastRow
CurrVal = .Cells(i, ColtoCheck)
NextVal = .Cells(i + 1, ColtoCheck).Value

If NextVal <> Empty And CurrVal <> Empty Then

Select Case CheckforStatus
Case "Increasing"
If NextVal < CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further
End If
Case "Decreasing"
If NextVal > CurrVal Then
.Cells(i + 1, ColtoCheck).Font.Color = vbRed
Exit For '<-- use if you dont want to process further

End If
End Select

End If

Next i
End With
End Sub

InitialD
02-03-2011, 07:22 AM
Thanks anandbohra! This works exactly how I wanted it to, I really appreciate the help.

InitialD
02-08-2011, 07:01 PM
Sorry to bother you again, but I ran into a little bug or problem.

I had some data with blanks, according to the data it should be increasing and turned the decreasing value to red, but it didn't for some reason. Please Help.
Should look something like this:

http://i1126.photobucket.com/albums/l601/Initial_D_1/bug2.jpg

http://i1126.photobucket.com/albums/l601/Initial_D_1/bug.jpg

PS: Is it possible for it to check more than 1 column?
Check all of column A, when it's done. Then Check next Column to see if its increasing or decreasing again. When that's done it'll check the next column, and so forth. It will continue to check and repeat. until the column will not have any values.
Look something like this:
http://i1126.photobucket.com/albums/l601/Initial_D_1/example.jpg

shrivallabha
02-08-2011, 09:57 PM
Test the attached file. If the code is satisfactory then we can repeat it easily for all columns.

InitialD
02-09-2011, 07:03 AM
Thanks Shrivallabha, it works.

But is it possible to tweak it so that it doesn't stop after it finds the first error.

Like having it continue to scan through the rest of the column for any other errors and turn those into red as well.

If possible, Can it also automatically copy and paste those errors to a "new sheet"?
Like if Column A has an error in A5, it will copy that value to a "specified work sheet, call 'errors'" in column A5. If there is an error in D6, it will copy that value to the same "error work sheet" in D6, and so forth.

Thanks a lot.

Thanks.

InitialD
02-09-2011, 08:00 AM
Also, can it be tweaked so that it will start the check between the top row, and say row 5 instead.

For Ex:

5<--- top row




4<--- 5th row, checking pattern, determined decreasing
3
3
5<--- error here, turn red, export to "error sheet" for that cell.
3

shrivallabha
02-09-2011, 09:23 PM
The first part can be taken care by this, I have commented out 'Exit Sub' which would exit after finding first item:
Sub OddManOut()
Dim TopRow As Long, LastRow As Long
Dim CurrVal As Integer, NextVal As Integer
'Find Top Most Filled Row
If Range("A1").Value = "" Then
TopRow = Range("A1").End(xlDown).Row
Else
TopRow = 1
End If
'Find Bottom Most Filled Row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Working out pattern
For i = TopRow To LastRow
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
Else
CurrVal = Range("A" & i).Value
If i = LastRow Then Exit Sub
i = Range("A" & i).End(xlDown).Row
NextVal = Range("A" & i + 1).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
End If
Next i
For i = TopRow To LastRow
Select Case Pattern
Case "Increasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal > NextVal Then
Range("A" & i + 1).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Value
If CurrVal > NextVal Then
Range("A" & i).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If
Case "Decreasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal < NextVal Then
Range("A" & i + 1).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Value
If CurrVal < NextVal Then
Range("A" & i).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If

End Select
Next i
End Sub


VBA can do many things you have stated. But the first always is to know what do you want!

InitialD
02-10-2011, 06:35 PM
Hi there is a little bug with the codes,
here's a picture of it below.

http://i1126.photobucket.com/albums/l601/Initial_D_1/bug3.jpg


This is what I want the code to do below.

http://i1126.photobucket.com/albums/l601/Initial_D_1/Ideal.jpg

shrivallabha
02-10-2011, 09:02 PM
Indeed, see if this does it for column A:
Sub OddManOut()
Dim TopRow As Long, LastRow As Long
Dim CurrVal As Integer, NextVal As Integer
'Find Top Most Filled Row
If Range("A1").Value = "" Then
TopRow = Range("A1").End(xlDown).Row
Else
TopRow = 1
End If
'Find Bottom Most Filled Row
LastRow = Range("A" & Rows.Count).End(xlUp).Row
'Working out pattern
For i = TopRow To LastRow
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
Else
CurrVal = Range("A" & i).Value
If i = LastRow Then Exit Sub
i = Range("A" & i).End(xlDown).Row
NextVal = Range("A" & i).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
End If
Next i
For i = TopRow To LastRow
Select Case Pattern
Case "Increasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal > NextVal Then
Range("A" & i + 1).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Value
If CurrVal > NextVal Then
Range("A" & i).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If
Case "Decreasing"
If Range("A" & i + 1).Value <> "" Then
CurrVal = Range("A" & i).Value
NextVal = Range("A" & i + 1).Value
If CurrVal < NextVal Then
Range("A" & i + 1).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Value
If CurrVal < NextVal Then
Range("A" & i).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If

End Select
Next i
End Sub

InitialD
02-11-2011, 11:29 AM
Yup! That does it for Column A.

If you are confused or have any questions about the code that I want from the picture posted, please let me know.

Thanks a lot!

InitialD
02-14-2011, 08:29 AM
I was thinking of using a LastCol Check, that checks the last column with values and offset the column by -1 to the left.

shrivallabha
02-15-2011, 05:59 AM
Hi, following is a lazy way of editing code. I have used offset property and Kenneth Hobs' trick for finding last column. See if it loops satisfactorily.
Sub OddManOut()
Dim TopRow As Long, LastRow As Long, lLastCol As Long
Dim CurrVal As Integer, NextVal As Integer
'Find the right most filled column
lLastCol = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
For k = 0 To lLastCol - 1
'Find Top Most Filled Row
If Range("A1").Offset(, k).Value = "" Then
TopRow = Range("A1").Offset(, k).End(xlDown).Row
Else
TopRow = 1
End If
'Find Bottom Most Filled Row
LastRow = Range("A" & Rows.Count).Offset(, k).End(xlUp).Row
'Working out pattern
For i = TopRow To LastRow
If Range("A" & i + 1).Offset(, k).Value <> "" Then
CurrVal = Range("A" & i).Offset(, k).Value
NextVal = Range("A" & i + 1).Offset(, k).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
Else
CurrVal = Range("A" & i).Offset(, k).Value
If i = LastRow Then Exit Sub
i = Range("A" & i).Offset(, k).End(xlDown).Row
NextVal = Range("A" & i).Offset(, k).Value
If CurrVal = NextVal Then
'Do Nothing
ElseIf CurrVal > NextVal Then
Pattern = "Decreasing"
TopRow = i
Exit For
Else
Pattern = "Increasing"
TopRow = i
Exit For
End If
End If
Next i
For i = TopRow To LastRow
Select Case Pattern
Case "Increasing"
If Range("A" & i + 1).Offset(, k).Value <> "" Then
CurrVal = Range("A" & i).Offset(, k).Value
NextVal = Range("A" & i + 1).Offset(, k).Value
If CurrVal > NextVal Then
Range("A" & i + 1).Offset(, k).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Offset(, k).Value
i = Range("A" & i).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Offset(, k).Value
If CurrVal > NextVal Then
Range("A" & i).Offset(, k).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If
Case "Decreasing"
If Range("A" & i + 1).Offset(, k).Value <> "" Then
CurrVal = Range("A" & i).Offset(, k).Value
NextVal = Range("A" & i + 1).Offset(, k).Value
If CurrVal < NextVal Then
Range("A" & i + 1).Offset(, k).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
Else
CurrVal = Range("A" & i).Offset(, k).Value
i = Range("A" & i).Offset(, k).End(xlDown).Row
If i = LastRow Then Exit Sub
NextVal = Range("A" & i).Offset(, k).Value
If CurrVal < NextVal Then
Range("A" & i).Offset(, k).Font.Color = vbRed
'Exit Sub
ElseIf CurrVal = NextVal Then
'Do Nothing
End If
i = i - 1
End If

End Select
Next i
Next k
End Sub

Sorry for late reply!

Bob Phillips
02-15-2011, 09:09 AM
Use conditional formatting with a formula of

=COUNTIF(A$1:A1,">"&A1)

for ascending numbers,

=COUNTIF(E$1:E1,"<"&E1)

for descending numbers

shrivallabha
02-16-2011, 08:32 AM
:bow: Thats amazing! Bob, probably silly thing to ask (since invariably I've got the advice I needed on this forum), I'd like to learn the art of conditional formatting.

Bob Phillips
02-16-2011, 08:40 AM
The art of CF Shrivallabha is being able to construct the formula that does what you want. This one is relatively simple, I gave a much more complex one yesterday to lukecj where he wanted to colour alternate blocks, but each 'block' only had its block id on the first row.

InitialD
02-16-2011, 05:10 PM
Thanks for the help, but the loop isn't looping correctly.