Code to fill the highest & lowest value from a range in 2 ranges

[hsandeep]

Range C2:C17 updates using formula & changes its value very fast.

In F2:F17 the highest value occurred in the cells C2:C17 is filled in ‘RESPECTIVE/CORRESPONDING’ cells of F2:F17 when A1=1 else ‘nothing is filled’.
In G2:G17 the lowest value occurred in the cells C2:C17 is filled in ‘RESPECTIVE/CORRESPONDING’ cells of G2:G17 when A1=1 else ‘nothing is filled’.

For this I am using the below code successfully till large extent (although it is slow in execution)

Private Sub Worksheet_Calculate()
'Code for Sheet H51
'Code checks/updates HIGHEST value occurred in C2:C16 & fills in F2:F16; C17 & fills in F17 when A1=1
'Code checks/updates LOWEST value occurred in C2:C3 & fills in G2:G16; C17 & fills in G17 when A1=1
Dim cell As Range
'Exit if A1 is not equal to 1
If Range("A1") <> 1 Then Exit Sub

'Loop through range of values that is being updated in C2:C16 & C17
For Each cell In Range("C2:C17")

'Check/update Maximum HIGHEST Value occurred in C2:C16 and FILL it in F2:F16; C17 in F17
If (Len(cell.Offset(0, 3)) > 0) And (IsNumeric(cell.Offset(0, 3))) Then
If cell > cell.Offset(0, 3) Then cell.Offset(0, 3) = cell
Else
cell.Offset(0, 3) = cell
End If

'Check/update Minimum LOWEST Value occurred in C2:C16 and FILL it in G2:G16; C17 in G17
If (Len(cell.Offset(0, 4)) > 0) And (IsNumeric(cell.Offset(0, 4))) Then
If cell < cell.Offset(0, 4) Then cell.Offset(0, 4) = cell
Else
cell.Offset(0, 4) = cell
End If
Next cell
End Sub

Book2.xlsx
	A	B	C	D	E	F	G
1	0		Value			Value HIGHEST	Value LOWEST
2			1140.10
3			1042.15
4			942.35
5			850.00
6			759.95
7			665.55
8			579.45
9			498.25
10			422.00
11			348.00
12			283.85
13			227.00
14			177.95
15			133.60
16			100.65
17			43233.90
H51

I want a new code to ADD the below action.
Range M2:M17 updates using formula & changes its value very fast. (in the same worksheet)

In P2:P17 the highest value occurred in the cells M2:M17 SHOULD BE FILLED in ‘RESPECTIVE/CORRESPONDING’ cells of P2:P17 when K1=1 else ‘nothing should be filled’.
In Q2:Q17 the lowest value occurred in the cells M2:M17 SHOULD BE FILLED in ‘RESPECTIVE/CORRESPONDING’ cells of Q2:Q17 when K1=1 else ‘nothing should be filled’.

Book2.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q
1	0		Value			Value HIGHEST	Value LOWEST				0		Value			Value HIGHEST	Value LOWEST
2			1140.10										1140.10
3			1042.15										1042.15
4			942.35										942.35
5			850.00										850.00
6			759.95										759.95
7			665.55										665.55
8			579.45										579.45
9			498.25										498.25
10			422.00										422.00
11			348.00										348.00
12			283.85										283.85
13			227.00										227.00
14			177.95										177.95
15			133.60										133.60
16			100.65										100.65
17			43233.90										43233.90
H51

Thanks in advance.

 

[Legacy 143009]

Please consider this code:

Private Sub Worksheet_Calculate()
  Dim myRangeC As Variant, myRangeCHtoL As Variant, myRangeCLtoH As Variant, myRangeM As Variant, myRangeMHtoL As Variant, myRangeMLtoH As Variant
  Dim i As Long
  myRangeC = Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)
  myRangeM = Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
  ReDim myRangeCHtoL(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeCLtoH(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeMHtoL(1 To UBound(myRangeM), 1 To 1)
  ReDim myRangeMLtoH(1 To UBound(myRangeM), 1 To 1)
  If Range("A1").Value = 1 Then
    For i = 1 To UBound(myRangeC, 1)
      myRangeCHtoL(i,1) = Application.Large(myRangeC, i)
      myRangeCLtoH(i,1) = Application.Small(myRangeC, i)
    Next
  End If
  If Range("K1").Value = 1 Then
    For i = 1 To UBound(myRangeM, 1)
      myRangeMHtoL(i,1) = Application.Large(myRangeM, i)
      myRangeMLtoH(i,1) = Application.Small(myRangeM, i)
    Next
  End If
  Application.ScreenUpdating = False
  Range("F2").Resize(UBound(myRangeCHtoL, 1), UBound(myRangeCHtoL, 2)) = myRangeCHtoL
  Range("G2").Resize(UBound(myRangeCLtoH, 1), UBound(myRangeCLtoH, 2)) = myRangeCLtoH
  Range("P2").Resize(UBound(myRangeMHtoL, 1), UBound(myRangeMHtoL, 2)) = myRangeMHtoL
  Range("Q2").Resize(UBound(myRangeMLtoH, 1), UBound(myRangeMLtoH, 2)) = myRangeMLtoH
  Application.ScreenUpdating = True
End Sub

 

[Legacy 143009]

Even you can get the cell updates inside ifs:

Private Sub Worksheet_Calculate()
  Dim myRangeC As Variant, myRangeCHtoL As Variant, myRangeCLtoH As Variant, myRangeM As Variant, myRangeMHtoL As Variant, myRangeMLtoH As Variant
  Dim i As Long

  myRangeC = Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)
  myRangeM = Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
  ReDim myRangeCHtoL(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeCLtoH(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeMHtoL(1 To UBound(myRangeM), 1 To 1)
  ReDim myRangeMLtoH(1 To UBound(myRangeM), 1 To 1)

  Application.ScreenUpdating = False
  If Range("A1").Value = 1 Then
    For i = 1 To UBound(myRangeC, 1)
      myRangeCHtoL(i,1) = Application.Large(myRangeC, i)
      myRangeCLtoH(i,1) = Application.Small(myRangeC, i)
    Next
    Range("F2").Resize(UBound(myRangeCHtoL, 1), UBound(myRangeCHtoL, 2)) = myRangeCHtoL
    Range("G2").Resize(UBound(myRangeCLtoH, 1), UBound(myRangeCLtoH, 2)) = myRangeCLtoH
  End If
  If Range("K1").Value = 1 Then
    For i = 1 To UBound(myRangeM, 1)
      myRangeMHtoL(i,1) = Application.Large(myRangeM, i)
      myRangeMLtoH(i,1) = Application.Small(myRangeM, i)
    Next
    Range("P2").Resize(UBound(myRangeMHtoL, 1), UBound(myRangeMHtoL, 2)) = myRangeMHtoL
    Range("Q2").Resize(UBound(myRangeMLtoH, 1), UBound(myRangeMLtoH, 2)) = myRangeMLtoH
  End If
  Application.ScreenUpdating = True
End Sub

 

[hsandeep]

Even you can get the cell updates inside ifs:

Private Sub Worksheet_Calculate()
  Dim myRangeC As Variant, myRangeCHtoL As Variant, myRangeCLtoH As Variant, myRangeM As Variant, myRangeMHtoL As Variant, myRangeMLtoH As Variant
  Dim i As Long

  myRangeC = Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)
  myRangeM = Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
  ReDim myRangeCHtoL(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeCLtoH(1 To UBound(myRangeC), 1 To 1)
  ReDim myRangeMHtoL(1 To UBound(myRangeM), 1 To 1)
  ReDim myRangeMLtoH(1 To UBound(myRangeM), 1 To 1)

  Application.ScreenUpdating = False
  If Range("A1").Value = 1 Then
    For i = 1 To UBound(myRangeC, 1)
      myRangeCHtoL(i,1) = Application.Large(myRangeC, i)
      myRangeCLtoH(i,1) = Application.Small(myRangeC, i)
    Next
    Range("F2").Resize(UBound(myRangeCHtoL, 1), UBound(myRangeCHtoL, 2)) = myRangeCHtoL
    Range("G2").Resize(UBound(myRangeCLtoH, 1), UBound(myRangeCLtoH, 2)) = myRangeCLtoH
  End If
  If Range("K1").Value = 1 Then
    For i = 1 To UBound(myRangeM, 1)
      myRangeMHtoL(i,1) = Application.Large(myRangeM, i)
      myRangeMLtoH(i,1) = Application.Small(myRangeM, i)
    Next
    Range("P2").Resize(UBound(myRangeMHtoL, 1), UBound(myRangeMHtoL, 2)) = myRangeMHtoL
    Range("Q2").Resize(UBound(myRangeMLtoH, 1), UBound(myRangeMLtoH, 2)) = myRangeMLtoH
  End If
  Application.ScreenUpdating = True
End Sub

@Flashbond
Many thanks for your interest shown & time & efforts given.
I think this code (thread #4) should run faster (but not tested till yet)

Actually, my total requirement is
There total 12 such ranges (10 more from the above 2 ranges) which are symmetrical in placement. The code’s action required is also ‘similar’
Example: (12th Range: )
Range DI2:DI17 updates using formula & changes its value very fast. (in the same worksheet)

In DL2:DL17 the highest value occurred in the cells DI2:DI17 SHOULD BE FILLED in ‘RESPECTIVE/CORRESPONDING’ cells of DL2:DL17 when DG1=1 else ‘nothing should be filled’.
In DM2:DM17 the lowest value occurred in the cells DI2:DI17 SHOULD BE FILLED in ‘RESPECTIVE/CORRESPONDING’ cells of DM2:DM17 when DG1=1 else ‘nothing should be filled’.

So I want to ADD 10 more ranges & run the code to give the desired results.
Main criteria is SPEED (code’s execution) & to avoid un-necessary loops.

Note: When A1 or its analogous like K1….till DG1 once they become 0 from 1 then they never become 1 again for that day. They remain 0.
Only 1 cell out of A1; K1; U1; AE1…..DG1 will be 1.

How to make the code FASTEST?

Book2.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG	BH	BI	BJ	BK	BL	BM	BN	BO	BP	BQ	BR	BS	BT	BU	BV	BW	BX	BY	BZ	CA	CB	CC	CD	CE	CF	CG	CH	CI	CJ	CK	CL	CM	CN	CO	CP	CQ	CR	CS	CT	CU	CV	CW	CX	CY	CZ	DA	DB	DC	DD	DE	DF	DG	DH	DI	DJ	DK	DL	DM
1	0		Value1			Value HIGHEST	Value LOWEST				0		Value2			Value HIGHEST	Value LOWEST				0		Value3			Value HIGHEST	Value LOWEST				0		Value4			Value HIGHEST	Value LOWEST				0		Value5			Value HIGHEST	Value LOWEST				0		Value6			Value HIGHEST	Value LOWEST				0		Value7			Value HIGHEST	Value LOWEST				0		Value8			Value HIGHEST	Value LOWEST				0		Value9			Value HIGHEST	Value LOWEST				0		Value10			Value HIGHEST	Value LOWEST				0		Value11			Value HIGHEST	Value LOWEST				0		Value12			Value HIGHEST	Value LOWEST
2			1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10										1140.10
3			1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15										1042.15
4			942.35										942.35										942.35										942.35										942.35										942.35										942.35										942.35										942.35										942.35										942.35										942.35
5			850.00										850.00										850.00										850.00										850.00										850.00										850.00										850.00										850.00										850.00										850.00										850.00
6			759.95										759.95										759.95										759.95										759.95										759.95										759.95										759.95										759.95										759.95										759.95										759.95
7			665.55										665.55										665.55										665.55										665.55										665.55										665.55										665.55										665.55										665.55										665.55										665.55
8			579.45										579.45										579.45										579.45										579.45										579.45										579.45										579.45										579.45										579.45										579.45										579.45
9			498.25										498.25										498.25										498.25										498.25										498.25										498.25										498.25										498.25										498.25										498.25										498.25
10			422.00										422.00										422.00										422.00										422.00										422.00										422.00										422.00										422.00										422.00										422.00										422.00
11			348.00										348.00										348.00										348.00										348.00										348.00										348.00										348.00										348.00										348.00										348.00										348.00
12			283.85										283.85										283.85										283.85										283.85										283.85										283.85										283.85										283.85										283.85										283.85										283.85
13			227.00										227.00										227.00										227.00										227.00										227.00										227.00										227.00										227.00										227.00										227.00										227.00
14			177.95										177.95										177.95										177.95										177.95										177.95										177.95										177.95										177.95										177.95										177.95										177.95
15			133.60										133.60										133.60										133.60										133.60										133.60										133.60										133.60										133.60										133.60										133.60										133.60
16			100.65										100.65										100.65										100.65										100.65										100.65										100.65										100.65										100.65										100.65										100.65										100.65
17			43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90										43233.90
H51

 

[Legacy 143009]

Then this should work:

Private Sub Worksheet_Calculate()
  Dim myRange As Variant
  Dim c As Long, r As Long

  myRange = UsedRange
  With Application
  For c = 1 To UBound(myRange, 2) Step 10
    If myRange(1, c) = 1 Then
      For r = 2 To UBound(myRange, 2)
        myRange(r, c + 5) = .IfError(.Large(.Index(myRange, 0, c + 2), r - 1), "")
        myRange(r, c + 6) = .IfError(.Small(.Index(myRange, 0, c + 2), r - 1), "")
      Next
    End If
  Next
  .ScreenUpdating = False
  UsedRange = myRange
  .ScreenUpdating = True
  End With
End Sub

 

[hsandeep]

Then this should work:

Private Sub Worksheet_Calculate()
  Dim myRange As Variant
  Dim c As Long, r As Long

  myRange = UsedRange
  With Application
  For c = 1 To UBound(myRange, 2) Step 10
    If myRange(1, c) = 1 Then
      For r = 2 To UBound(myRange, 2)
        myRange(r, c + 5) = .IfError(.Large(.Index(myRange, 0, c + 2), r - 1), "")
        myRange(r, c + 6) = .IfError(.Small(.Index(myRange, 0, c + 2), r - 1), "")
      Next
    End If
  Next
  .ScreenUpdating = False
  UsedRange = myRange
  .ScreenUpdating = True
  End With
End Sub

Will this code execute the required action for all the 12 ranges OR some modification in the code is suggested, Flashbond

 

[Legacy 143009]

No, nothing. Just use it

 

[hsandeep]

No, nothing. Just use it

Its giving error msg; Run-time error '9':
Subscript out of range

 

[Legacy 143009]

What are your actual ranges?

 

[Legacy 143009]

Oh sorry,

Try to change this line:

For r = 2 To UBound(myRange, 2)

Like this:

For r = 2 To UBound(myRange, 1)