Solved: Make sure numbers are increasing

[InitialD]

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]

Try this code.



[VBA]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
[/VBA]

[InitialD]

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]

Try this modified one

[VBA]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[/VBA]

[InitialD]

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]

Try this
I applied your both example & found to be correct this time

[VBA]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
[/VBA]

[InitialD]

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]

The reason for failure is at the time of initialization how does the system recognize whether its Increasing or Decreasing?
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]

It will check for the first pattern and assume it to be correct. See if this is what you are looking for:
[VBA]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
[/VBA]

[InitialD]

There's an error when I ran it. It says Run-time error, Method ' Range' of object '_Global' failed. It highlited line 84

[InitialD]

The reason for failure is at the time of initialization how does the system recognize whether its Increasing or Decreasing?
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



Conversely if increasing, it does this

[anandbohra]

This code is tested on both the examples & gave me exact red highlighting as per your example.

[VBA]
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[/VBA]

[InitialD]

Thanks anandbohra! This works exactly how I wanted it to, I really appreciate the help.

[InitialD]

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:





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:

[shrivallabha]

Test the attached file. If the code is satisfactory then we can repeat it easily for all columns.

[InitialD]

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]

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]

The first part can be taken care by this, I have commented out 'Exit Sub' which would exit after finding first item:
[vba]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]

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

[InitialD]

Hi there is a little bug with the codes,
here's a picture of it below.




This is what I want the code to do below.

[shrivallabha]

Indeed, see if this does it for column A:
[vba]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
[/vba]