Mininum Maximum

[olegvolf]

Hello
I am completely lost.
I have a table of date(attached) and i am trying to do is to make 2 additional rows below the table
that one is the maximum and next row is the minimum according to the date range(column "date") that need to be specified in 2 cells(any 2 cells) or range of serials from 2 cells(any 2 cells).

Please tour help of resolving this issue.

Thank you very much.
Regards,
Oleg Volfson

[p45cal]

In the attached find in cells AT182:AT183 data validation using all the dates in the table which seem to be in order and all unique.
In cells AT186:AT187 data validation using range AX4:AX115 which is a list created by advanced filter of the serial numbers to leave only unique serials, then sorted.
Dates:
In cell AR182 is a formula which MUST BE ARRAY-ENTERED (that is committed to the sheet with Ctrl+Shift+Enter, not just Enter)
The formula below it in cell AR183 is exactly the same formula except MIN has been replaced with MAX.
These last two cells can be autofilled to the left.
Serials:
The formula in AR186 is very similar to that in AR182 except that it refers to the two serial numbers in AT186:AT187 instead of the two dates.
The formula below it in cell AR187 is exactly the same formula except MIN has been replaced with MAX.
These last two cells can be autofilled to the left.

I hope they give the right answers!

[olegvolf]

In the attached find in cells AT182:AT183 data validation using all the dates in the table which seem to be in order and all unique.
In cells AT186:AT187 data validation using range AX4:AX115 which is a list created by advanced filter of the serial numbers to leave only unique serials, then sorted.
Dates:
In cell AR182 is a formula which MUST BE ARRAY-ENTERED (that is committed to the sheet with Ctrl+Shift+Enter, not just Enter)
The formula below it in cell AR183 is exactly the same formula except MIN has been replaced with MAX.
These last two cells can be autofilled to the left.
Serials:
The formula in AR186 is very similar to that in AR182 except that it refers to the two serial numbers in AT186:AT187 instead of the two dates.
The formula below it in cell AR187 is exactly the same formula except MIN has been replaced with MAX.
These last two cells can be autofilled to the left.

I hope they give the right answers!

Thank you very much for your replay.
The data can go for more than 5000 rows and because of that i was looking for a macro solution.
Regards
Oleg

[Paul_Hossler]

There's some polishing that could be done, but tried to be straight forward. I think I understood the question

1. For small amount of data (e.g. 5K- 100K rows) I usually just loop instead of filters, etc.

My OPINION is that FOR ME it's easier to maintain and understand when I come back to it later

2. Instead of entering dates, it's easy to make it a point and click selection

3. No status updates since it runs quickly




Option Explicit
Public Const cModuleName As String = "AddMaxMinRows"
Public Const cTimeColumn As Long = 46

Sub AddMaxMinRows()
Dim sInput As String
Dim dtStart As Date, dtEnd As Date
Dim rData As Range, rMin As Range, rMax As Range
Dim iMinRow As Long, iMaxRow As Long, iRow As Long, iColumn As Long, iLastRow As Long

'get dates
sInput = Application.InputBox("Enter Starting Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtStart = CDate(sInput)
End If

sInput = Application.InputBox("Enter Ending Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtEnd = CDate(sInput)
End If

Application.ScreenUpdating = False

'don't like doing it this way, since it's hardcoded
Set rData = ActiveSheet.Cells(7, cTimeColumn).CurrentRegion

Application.ScreenUpdating = False

'remove any previous max and min rows at the bottom - assuming the time cell is blank
With rData
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete

iLastRow = .Rows(.Rows.Count).Row
End With

With ActiveSheet
iMinRow = iLastRow + 1
iMaxRow = iLastRow + 2

For iColumn = 1 To cTimeColumn - 2
For iRow = 7 To iLastRow

If (dtStart <= .Cells(iRow, cTimeColumn).Value) And (.Cells(iRow, cTimeColumn).Value <= dtEnd) Then

'special check for blank mins (=0)
If Len(.Cells(iMinRow, iColumn).Value) = 0 Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value < .Cells(iMinRow, iColumn).Value Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

If .Cells(iRow, iColumn).Value = 3.0161 Then Stop

If .Cells(iRow, iColumn).Value > .Cells(iMaxRow, iColumn).Value Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

End If

Next iRow
Next iColumn
End With
Application.ScreenUpdating = True
Call MsgBox("Added Min and Max rows between " & Format(dtStart, "m/d/yyyy") & " and " & Format(dtEnd, "m/d/yyyy"), vbInformation + vbOKOnly, cModuleName)
End Sub

[olegvolf]

Hello
thank you very much for your answer
it is great/
2 questions.
Can you please explain to me what you ment in # 2 regarding the dates?
How can i make the same selection fpr the serial numbers?

[olegvolf]

There's some polishing that could be done, but tried to be straight forward. I think I understood the question

1. For small amount of data (e.g. 5K- 100K rows) I usually just loop instead of filters, etc.

My OPINION is that FOR ME it's easier to maintain and understand when I come back to it later

2. Instead of entering dates, it's easy to make it a point and click selection

3. No status updates since it runs quickly




Option Explicit
Public Const cModuleName As String = "AddMaxMinRows"
Public Const cTimeColumn As Long = 46

Sub AddMaxMinRows()
Dim sInput As String
Dim dtStart As Date, dtEnd As Date
Dim rData As Range, rMin As Range, rMax As Range
Dim iMinRow As Long, iMaxRow As Long, iRow As Long, iColumn As Long, iLastRow As Long

'get dates
sInput = Application.InputBox("Enter Starting Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtStart = CDate(sInput)
End If

sInput = Application.InputBox("Enter Ending Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtEnd = CDate(sInput)
End If

Application.ScreenUpdating = False

'don't like doing it this way, since it's hardcoded
Set rData = ActiveSheet.Cells(7, cTimeColumn).CurrentRegion

Application.ScreenUpdating = False

'remove any previous max and min rows at the bottom - assuming the time cell is blank
With rData
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete

iLastRow = .Rows(.Rows.Count).Row
End With

With ActiveSheet
iMinRow = iLastRow + 1
iMaxRow = iLastRow + 2

For iColumn = 1 To cTimeColumn - 2
For iRow = 7 To iLastRow

If (dtStart <= .Cells(iRow, cTimeColumn).Value) And (.Cells(iRow, cTimeColumn).Value <= dtEnd) Then

'special check for blank mins (=0)
If Len(.Cells(iMinRow, iColumn).Value) = 0 Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value < .Cells(iMinRow, iColumn).Value Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

If .Cells(iRow, iColumn).Value = 3.0161 Then Stop

If .Cells(iRow, iColumn).Value > .Cells(iMaxRow, iColumn).Value Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

End If

Next iRow
Next iColumn
End With
Application.ScreenUpdating = True
Call MsgBox("Added Min and Max rows between " & Format(dtStart, "m/d/yyyy") & " and " & Format(dtEnd, "m/d/yyyy"), vbInformation + vbOKOnly, cModuleName)
End Sub



Hello
I worked till know and thinking that you are correct.
I want to make it simpler.
Made instead of dates it is possible to make the same thing (maximum and minimun in 2 rows) only for 40 last rows and list the serials of those rows in differant sheet?
\

[Paul_Hossler]

I left a debug line that should be deleted



If .Cells(iRow, iColumn).Value = 3.0161 Then Stop


Instead of manually entering dates, it is possible

a. to just click on the early and the end dates, or

b. you can have 2 cells on the worksheet that hold the start and end.

Either way is easy



Made instead of dates it is possible to make the same thing (maximum and minimun in 2 rows) only for 40 last rows and list the serials of those rows in differant sheet?


c. Not check dates at all, but only look at the last 40 rows and put the max/min's on to a new sheet?

[olegvolf]

I left a debug line that should be deleted



If .Cells(iRow, iColumn).Value = 3.0161 Then Stop


Instead of manually entering dates, it is possible

a. to just click on the early and the end dates, or

b. you can have 2 cells on the worksheet that hold the start and end.

Either way is easy



c. Not check dates at all, but only look at the last 40 rows and put the max/min's on to a new sheet?
Hi
Thank you for the replay.
The max and min values can stay at the end like it was but the serials from the serials column that belongs to those 40 to copy to new sheet.

Thanks
Oleg

[Paul_Hossler]

... that belongs to those 40 to copy to new sheet.


The number min and max that are checked depend on the starting and ending dates and could be any number

Serials from the last 40 rows can be copied to another sheet, but would most likely not be the rows that were used to select the max and mins

Is that what you're asking for?

[olegvolf]

The number min and max that are checked depend on the starting and ending dates and could be any number

Serials from the last 40 rows can be copied to another sheet, but would most likely not be the rows that were used to select the max and mins

Is that what you're asking for?
Hello and thank you again.
Yes.
If we are taking the last 40 than the numers should be copied.
And when we are filtering according to the dates no need to copy because you are perfectly correct.

[Paul_Hossler]

Still not sure I'm understanding, but added logic to always copy the last 40 part numbers to a new sheet.
This are not the part numbers in a date range used to determine min and max, but the macro can be easily changed if that's what your want




Option Explicit
Public Const cModuleName As String = "AddMaxMinRows"
Public Const cTimeColumn As Long = 46
Public Const cPartColumn As Long = 47

Sub AddMaxMinRows()
Dim sInput As String
Dim dtStart As Date, dtEnd As Date
Dim rData As Range, rMin As Range, rMax As Range
Dim iMinRow As Long, iMaxRow As Long, iRow As Long, iColumn As Long, iLastRow As Long
Dim iStartOf40 As Long, iRowFor40 As Long
Dim wsData As Worksheet, wsPartNumbers As Worksheet

'get dates
sInput = Application.InputBox("Enter Starting Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtStart = CDate(sInput)
End If

sInput = Application.InputBox("Enter Ending Date", cModuleName, 0, , , , , 2)
If sInput = "0" Then
Call MsgBox("You entered '0' to Exit", vbOKOnly + vbInformation, cModuleName)
Exit Sub
ElseIf Not IsDate(sInput) Then
Call MsgBox("You did not enter a date", vbOKOnly + vbInformation, cModuleName)
Exit Sub
Else
dtEnd = CDate(sInput)
End If

Application.ScreenUpdating = False
Set wsData = ActiveSheet

'don't like doing it this way, since it's hardcoded
Set rData = wsData.Cells(7, cTimeColumn).CurrentRegion

Application.ScreenUpdating = False

'remove any previous max and min rows at the bottom - assuming the time cell is blank
With rData
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete
If Len(.Cells(.Rows.Count, cTimeColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete

iLastRow = .Rows(.Rows.Count).Row
End With


'add new sheet to hold last 40 (max) part numbers
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("PartNumbers").Delete
Application.DisplayAlerts = True
On Error GoTo 0

ActiveWorkbook.Worksheets.Add.Name = "PartNumbers"
Set wsPartNumbers = ActiveWorkbook.Worksheets("PartNumbers")

With wsData
iMinRow = iLastRow + 1
iMaxRow = iLastRow + 2

For iColumn = 1 To cTimeColumn - 2
For iRow = 7 To iLastRow

If (dtStart <= .Cells(iRow, cTimeColumn).Value) And (.Cells(iRow, cTimeColumn).Value <= dtEnd) Then

'special check for blank mins (=0)
If Len(.Cells(iMinRow, iColumn).Value) = 0 Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value < .Cells(iMinRow, iColumn).Value Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

If .Cells(iRow, iColumn).Value > .Cells(iMaxRow, iColumn).Value Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

End If

Next iRow
Next iColumn

'find start of the 40 rows to copy
iStartOf40 = iLastRow - 39
If iStartOf40 < 7 Then iStartOf40 = 7

iRowFor40 = 1

For iRow = iStartOf40 To iLastRow
wsPartNumbers.Cells(iRowFor40, 1).Value = .Cells(iRow, cPartColumn).Value
iRowFor40 = iRowFor40 + 1
Next iRow
End With

Application.ScreenUpdating = True
Call MsgBox("Added Min and Max rows between " & Format(dtStart, "m/d/yyyy") & " and " & Format(dtEnd, "m/d/yyyy"), vbInformation + vbOKOnly, cModuleName)
End Sub



My approach is very brute force, but since performance is OK it's easier to maintain.

There are numerous improvements that can be made to increase performance, but with increased complexity

1. If the data is sorted in time order the macro can be made faster
2. Instead of explicitly checking for max and min for each column and each row, a worksheet formula using a row range could be used one time per column

[olegvolf]

Hello
Thanks
I understand what you meant.
The macro is working great.
How can i edit it to disregard the dates at all and do the max/min for the last 40 rows and copy thear serial.
You are correct it makes much more sence

Regards

Oleg

[Paul_Hossler]

Try this




Option Explicit
Public Const cModuleName As String = "CopyLast40"
Public Const cPartColumn As Long = 47

Sub CopyLast40()
Dim iRow As Long, iColumn As Long, iLastRow As Long
Dim iStartOf40 As Long, iRowFor40 As Long
Dim wsData As Worksheet, wsPartNumbers As Worksheet


Application.ScreenUpdating = False
Set wsData = ActiveSheet

'don't like doing it this way, since it's hardcoded
iLastRow = wsData.Cells(7, cPartColumn).End(xlDown).Row


'add new sheet to hold last 40 (max) part numbers
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("PartNumbers").Delete
Application.DisplayAlerts = True
On Error GoTo 0

ActiveWorkbook.Worksheets.Add.Name = "PartNumbers"
Set wsPartNumbers = ActiveWorkbook.Worksheets("PartNumbers")

With wsData

'find start of the 40 rows to copy
iStartOf40 = iLastRow - 39
If iStartOf40 < 7 Then iStartOf40 = 7

iRowFor40 = 1

For iRow = iStartOf40 To iLastRow
wsPartNumbers.Cells(iRowFor40, 1).Value = .Cells(iRow, cPartColumn).Value
iRowFor40 = iRowFor40 + 1
Next iRow
End With

Application.ScreenUpdating = True
Call MsgBox("Added Last Forty Part Numbers", vbInformation + vbOKOnly, cModuleName)
End Sub

[olegvolf]

Try this




Option Explicit
Public Const cModuleName As String = "CopyLast40"
Public Const cPartColumn As Long = 47

Sub CopyLast40()
Dim iRow As Long, iColumn As Long, iLastRow As Long
Dim iStartOf40 As Long, iRowFor40 As Long
Dim wsData As Worksheet, wsPartNumbers As Worksheet


Application.ScreenUpdating = False
Set wsData = ActiveSheet

'don't like doing it this way, since it's hardcoded
iLastRow = wsData.Cells(7, cPartColumn).End(xlDown).Row


'add new sheet to hold last 40 (max) part numbers
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("PartNumbers").Delete
Application.DisplayAlerts = True
On Error GoTo 0

ActiveWorkbook.Worksheets.Add.Name = "PartNumbers"
Set wsPartNumbers = ActiveWorkbook.Worksheets("PartNumbers")

With wsData

'find start of the 40 rows to copy
iStartOf40 = iLastRow - 39
If iStartOf40 < 7 Then iStartOf40 = 7

iRowFor40 = 1

For iRow = iStartOf40 To iLastRow
wsPartNumbers.Cells(iRowFor40, 1).Value = .Cells(iRow, cPartColumn).Value
iRowFor40 = iRowFor40 + 1
Next iRow
End With

Application.ScreenUpdating = True
Call MsgBox("Added Last Forty Part Numbers", vbInformation + vbOKOnly, cModuleName)
End Sub


Hello and thank you.
According to the code you removed the maximun and minimum.
I meant that to make max and min calculation for the lasto 40 and copy their serials.
Thabk you and sorry that i have so many questions

[olegvolf]

Hello and thank you.
According to the code you removed the maximun and minimum.
I meant that to make max and min calculation for the lasto 40 and copy their serials.
Thabk you and sorry that i have so many questions

Hello
can you please help me with the last question and i will finish the project.
I want to thank you for all your help that provided me.
without you could not be able to promote an inch.

Thanks Regards
Oleg Volfson

[Paul_Hossler]

How's this?




Option Explicit
Public Const cModuleName As String = "AddMaxMinRows"
Public Const cPartColumn As Long = 47

Sub AddMaxMinRows()
Dim rData As Range, rMin As Range, rMax As Range
Dim iMinRow As Long, iMaxRow As Long, iRow As Long, iColumn As Long, iLastRow As Long
Dim iStartOf40 As Long, iRowFor40 As Long
Dim wsData As Worksheet, wsPartNumbers As Worksheet

Application.ScreenUpdating = False
Set wsData = ActiveSheet

'don't like doing it this way, since it's hardcoded
Set rData = wsData.Cells(7, cPartColumn).CurrentRegion

Application.ScreenUpdating = False

'remove any previous max and min rows at the bottom - assuming the part cell is blank
With rData
If Len(.Cells(.Rows.Count, cPartColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete
If Len(.Cells(.Rows.Count, cPartColumn).Value) = 0 Then .Rows(.Rows.Count).EntireRow.Delete

iLastRow = .Rows(.Rows.Count).Row
End With


'add new sheet to hold last 40 (max) part numbers
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("PartNumbers").Delete
Application.DisplayAlerts = True
On Error GoTo 0

ActiveWorkbook.Worksheets.Add.Name = "PartNumbers"
Set wsPartNumbers = ActiveWorkbook.Worksheets("PartNumbers")

With wsData

'find start of the 40 rows to copy
iStartOf40 = iLastRow - 39
If iStartOf40 < 7 Then iStartOf40 = 7

iRowFor40 = 1
For iRow = iStartOf40 To iLastRow
wsPartNumbers.Cells(iRowFor40, 1).Value = .Cells(iRow, cPartColumn).Value
iRowFor40 = iRowFor40 + 1
Next iRow

'now do max min
iMinRow = iLastRow + 1
iMaxRow = iLastRow + 2

For iColumn = 1 To cPartColumn - 3
For iRow = iStartOf40 To iLastRow
'special check for blank mins (=0)
If Len(.Cells(iMinRow, iColumn).Value) = 0 Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value < .Cells(iMinRow, iColumn).Value Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

If .Cells(iRow, iColumn).Value > .Cells(iMaxRow, iColumn).Value Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

Next iRow
Next iColumn
End With

Application.ScreenUpdating = True
Call MsgBox("Added Min and Max for last " & (iLastRow - iStartOf40 + 1) & " rows", vbInformation + vbOKOnly, cModuleName)
End Sub

[olegvolf]

Hi
Thanks
it works great but the in the column AR did calculated max value.
Regards Oleg

[Paul_Hossler]

sorry about that -- AR was the only column that had all negative numbers

add / replace the lines in red and you should be OK





For iColumn = 1 To cPartColumn - 3
For iRow = iStartOf40 To iLastRow
'special check for blank mins (=0)
If Len(.Cells(iMinRow, iColumn).Value) = 0 Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value < .Cells(iMinRow, iColumn).Value Then
.Cells(iMinRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

'special check for blank maxs (=0)
If Len(.Cells(iMaxRow, iColumn).Value) = 0 Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
ElseIf .Cells(iRow, iColumn).Value > .Cells(iMaxRow, iColumn).Value Then
.Cells(iMaxRow, iColumn).Value = .Cells(iRow, iColumn).Value
End If

Next iRow
Next iColumn

[olegvolf]

Hello
Thank you so much it works great.
Oleg