Trouble getting lows and highs data analyzed and marked with my critera requirements

[Goldn]

All,
I really need this worked out. I am working with MS Office 2021 Professional Plus, but If i absolutely have to get 365 for these fixes then I will.

Reason for Inquiry and Problem:
I reviewed some analysis work I manually did on an excel sheet, and much to my dismay I noticed some human errors on my part as a result. I've tried multiple things (conditional formatting, etc, and also asked an accountant friend of mine who works with Excel a lot, and I still don't have a fix for this. Fixing this issue with Excel doing this automatically instead of me doing this work manually will significantly reduce analysis time, remove much tedious "busywork," as well as eliminate human error.

Preliminary:
1. Let's start with only a single column with no empty cell rows (multiple columns are desired, along with multiple rows with blank data (weekends/holidays), but for the sake of simplicity let's attempt only one column at a time first with no empty weekend/holiday rows.

Issue and desire:
Have Excel search an entire single column which has number-only data in each row. Number of rows may differ each time I do this, as the column may be 12,000 rows of cells at a time (A1 - A12,000, for example, and another search of a single column may only have 4,000 rows).
Note that each cell might contain a number with no decimal (such as 144), while other cells/rows may contain a number which contains a decimal (such as 50.3456 for example).
2. Have Excel search and color-fill every cell row in the column (and/or a range of cells such as within column "A," only rows 4,000 - 6,000) which has the following criteria:
1. The cell in the row which has a lesser value than a customizable number of cells in the rows previous AND after it.
A simplified example would be this: I'd like it to search the entire column and have Excel color-fill every cell that has a lesser value than the
previous 2 cells before (2 rows before) AND the subsequent 2 cells after (2 rows after).
** I'd like to be able to change the criteria as well. For example instead of 2 cells before and 2 cells after, maybe change it to 10 cells before
and 5 cells after, etc (customizable, basically).

2. I'm also trying to accomplish the same thing but with higher values instead of lesser values as well, and with a different color to
distinguish lows versus highs (red and green, for example).


3. Separately, I would also find it helpful and useful if I could also have a separate fix for doing the same thing, except this time instead of color-filling the cells, to instead mark the cell in the same row with "H" or "L" ("H" for the high value cells and "L" for the low value cells, respectively.

4. Have Excel do the same search/analyzation & marking executions mentioned in all of the above, but with multiple columns (as this is desirable at
times) instead of only one column at a time (for the sake of time-saving and again, human error that I've come across which tends to occur if done for long periods of time).

5. Have Excel do the above requests, but ONLY within a customizable column range instead of the entire column, which is applicable at certain times.
(example would be column A, rows 2,000 - 3,500, for multiple columns then it might include column C for the same rows).

I hope this was clearly understood. This could prove extremely useful for cycle hunting as well as other things pertaining to life.
Grace and Joy to you.
Thanks in advance,
S

 

[I_know_nuffin]

for parts 1 & 2 for column A use the below

Sub colouracell()

Dim x As Long
Dim rowsabove As Integer, rowsbelow As Integer
Dim chknum As Long, check As Integer

rowsabove = InputBox("Enter number of rows above ")
rowsbelow = InputBox("Enter number of rows below")

Application.ScreenUpdating = False

For x = (rowsabove + 2) To (Range("A1").End(xlDown).Row - rowsbelow)
counter = 0

Range("A" & x).Select

check = 0
For y = x - rowsbelow To x + rowsabove
  If Range("A" & x) <= Range("A" & y) Then
  Else
    check = 1
    y = (x + rowsbelow) + 1
  End If
Next y

If check = 0 Then Range("A" & x).Interior.ColorIndex = 4 'Green

check = 0
For y = x - rowsbelow To x + rowsabove
  If Range("A" & x) >= Range("A" & y) Then
  Else
    check = 1
    y = (x + rowsbelow) + 1
  End If
Next y

If check = 0 Then Range("A" & x).Interior.ColorIndex = 3 'red

Next x
Application.ScreenUpdating = True
End Sub

 

[Goldn]

I'm afraid that didn't work. View screenshots.
It didn't work with my data, and I thought it might be incorrect, so I manually input some simple numbers which should have worked (and thus color-filled the cells) but it doesn't. It gives me the "error 13 mismatch" I have input "5" for both lines, "3," 2," re-save as macro-enabled workbook, run the macro, with the same result.

 

[I_know_nuffin]

Hi

the input box should open a dialog box for you to input the numbers - to allow you to alter outside of the vba

you need to remove both of the "2" and run it

 

[I_know_nuffin]

or change these lines
rowsabove = InputBox("Enter number of rows above ")
rowsbelow = InputBox("Enter number of rows below")
to
rowsabove = 2
rowsbelow = 2

but you will need to update the numbers in the code every time they need to change

Also the code expects a Header in Row 1

 

[I_know_nuffin]

works ok for me

 

[Goldn]

I apologize, as the problem was me inputting a value in the code itself. My bad on that. Thank you so much for your help!
Any ideas on questions 3 through 5?
Respectfully,
S

 

[I_know_nuffin]

Hi Goldn

no need to apologise


Try the below for the other options should work for single / multiple columns

Sub colouracell_multicolumn()

Dim x As Long
Dim rowsabove As Integer, rowsbelow As Integer
Dim chknum As Long, check As Integer, colchr As String
Dim actionrng As Range
Dim Lastrow As Long, LastColumn As Long, Firstrow As Long, Firstcolumn As Long
Dim columncheck As Integer, firstcolchr As String, lastcolchr As String, headerrow As Long


' ask whether to use the same number range (above and below) for each column or
' enter a new range for every column as it is selected

columncheck = MsgBox("Do you want to enter a new check range for each column?", vbYesNo)

Firstrow = 1
Firstcolumn = 1
Lastrow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn = ActiveSheet.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

If MsgBox("Do you want to search a specific range of rows ?", vbYesNo) = vbYes Then
  Firstrow = InputBox("Enter the number of the first row to use between 1 and " & Lastrow)
  Lastrow = InputBox("Enter the number of last row to use between " & Firstrow & " and " & Lastrow)
End If

  If Firstrow = 1 Then
    headerrow = 1
  Else
    headerrow = 0
  End If


' to select a range of columns unconmment the below
'If MsgBox("Do you want to search a specific range of columns ?", vbYesNo) = vbYes Then
'
'' using numbers to select the columns
'  Firstcol = InputBox("Enter the number of the first column to use between 1 and " & LastColumn)
'  LastColumn = InputBox("Enter the number of last column to use between " & Firstcolumn & " and " & LastColumn)
'
'' using letters to select the columns
'  firstcolchr = Split(Cells(1, Firstcolumn).Address, "$")(1)
'  lastcolchr = Split(Cells(1, LastColumn).Address, "$")(1)
'  firstcolchr = InputBox("Enter the Letter of the first column to use between A and " & lastcolchr)
'  lastcolchr = InputBox("Enter the Letter of last column to use between " & firstcolchr & " and " & lastcolchr)
'  Firstcol = Columns(firstcolchr).Column
'  LastColumn = Columns(lastcolchr).Column
'
'End If


Set actionrng = ActiveSheet.Range(Cells(Firstrow, Firstcolumn), Cells(Lastrow, LastColumn))

If columncheck = vbNo Then
rowsabove = InputBox("Enter number of rows above for all Columns ")
rowsbelow = InputBox("Enter number of rows below for all Columns ")
End If


For Each Column In actionrng.Columns
'Debug.Print Column.Column,
colchr = Split(Cells(1, Column.Column).Address, "$")(1)
colno = Column.Column

Range(Cells(1, colno), Cells(1, colno)).Select


If columncheck = vbYes Then
rowsabove = InputBox("Enter number of rows above for Column " & colchr)
rowsbelow = InputBox("Enter number of rows below for Column " & colchr)
End If


Application.ScreenUpdating = False

For x = Firstrow + (rowsabove + headerrow) To Lastrow - rowsbelow '(Range("A1").End(xlDown).Row - rowsbelow)
counter = 0
'If colno = 8 Then Stop
'If colno = 8 Then Range(Cells(x, colno), Cells(x, colno)).Select
'ActiveSheet.Range(Cells(x, colno), Cells(x, colno)).Select
If Not IsNumeric(Range(Cells(x, colno), Cells(x, colno))) Then Exit For
If Range(Cells(x, colno), Cells(x, colno)) = "" Then Exit For
'Debug.Print Range(Cells(x, Colno), Cells(x, Colno))


check = 0
For y = x - rowsabove To x + rowsbelow
  If Range(Cells(x, colno), Cells(x, colno)) <= Range(Cells(y, colno), Cells(y, colno)) Then  'Range(Column.Column, x) <= Range(Column.Column, y) Then
  'check if the numbers are the same and if they are return a false test for the range
  If Range(Cells(x, colno), Cells(x, colno)) = Range(Cells(y, colno), Cells(y, colno)) And y <> x Then check = 1
  Else
    check = 1
    y = (x + rowsbelow) + 1   'rowsbelow) + 1
  End If
Next y

If check = 0 Then Range(Cells(x, colno), Cells(x, colno)).Interior.ColorIndex = 4 'Green  'Range(Column.Column, x).Interior.ColorIndex = 4 'Green

check = 0
For y = x - rowsabove To x + rowsbelow
  If Range(Cells(x, colno), Cells(x, colno)) >= Range(Cells(y, colno), Cells(y, colno)) Then  'Range(Column.Column, x) >= Range(Column.Column, y) Then
  'check if the numbers are the same and if they are return a false test for the range
  If Range(Cells(x, colno), Cells(x, colno)) = Range(Cells(y, colno), Cells(y, colno)) And y <> x Then check = 1
  Else
    check = 1
    y = (x + rowsbelow) + 1 'rowsbelow) + 1
  End If
Next y

If check = 0 Then Range(Cells(x, colno), Cells(x, colno)).Interior.ColorIndex = 3  'red 'Range(Column.Column, x).Interior.ColorIndex = 3 'red

'If x > 40000 Then Stop
Next x
'If x > 100 Then Stop
Application.ScreenUpdating = True
Next Column


End Sub