View Full Version : [SOLVED:] Mininum Maximum
olegvolf
11-20-2014, 05:42 AM
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
11-20-2014, 12:32 PM
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
11-20-2014, 11:25 PM
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
11-21-2014, 07:03 AM
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
11-21-2014, 07:45 AM
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
11-21-2014, 11:52 AM
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
11-22-2014, 12:24 PM
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
11-22-2014, 12:38 PM
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
11-22-2014, 04:36 PM
... 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
11-22-2014, 09:53 PM
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
11-23-2014, 07:16 AM
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
11-23-2014, 07:32 AM
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
11-23-2014, 05:37 PM
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
11-23-2014, 07:41 PM
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
11-24-2014, 04:03 AM
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
11-24-2014, 06:01 AM
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
11-24-2014, 06:20 AM
Hi
Thanks
it works great but the in the column AR did calculated max value.
Regards Oleg
Paul_Hossler
11-24-2014, 06:35 AM
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
11-24-2014, 06:53 AM
Hello
Thank you so much it works great.
Oleg
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.