This is not a "do this and all will be well" answer because I do not quite understand what you are attempting. However, I hope this answer includes enough pointers for you to create the code you seek.
Issue 1
You are absolutely correct to use a worksheet function rather than your own VBA when a suitable worksheet function exists since the worksheet function will be substantially faster. However, if there is any way of getting the Max function to return the row, I do not know it. I believe you will have to use VBA to scan each column.
Issue 2
On Error Resume Next should never be used like this since all errors will be ignored. Ideally you avoid errors by checking in advance. If you want to open a file, you should check it exists before attempting the open rather than wait for the open to fail and give an error. However, there are some situations in which you cannot check for an error. In such situations you can use On Error Resume Next so:
Err.Clear
On Error Resume Next
' Statement that might fail
On Error GoTo 0
If Err.Number <> 0 Then
' Statement failed.
' Description of failure in Err.Description.
' Report error with user friendly message and exit or take corrective action.
End If
Issue 3
Please indent your code so it is easier to read and spot errors. For example:
1 Public Sub run_CalcPeakTemp()
2 Dim myCalRange As Range
3 Dim iReply As Integer
4 'On Error Resume Next
5 Set myCalcRange = Application.InputBox(Prompt:="Select first row and then Ctrl+Shift+down", _
6 Title:="Select Range", Type:=8)
7 myCalcRange.Select
8 If myCalcRange Is Nothing Then
9 iReply = MsgBox("Range not selected!")
10 Exit Sub
11 If myCalcRange Is notNothing Then
12 Call run_CalcPeakTemp
13 End If
14 End If
15 End Sub
I have added the line numbers so I can reference statements easily. I have also split line 5 over two lines so most of it is visible.
Issue 4
On line 2, you declare myCalRange. Elsewhere within the routine you use myCalcRange. If the first statement of your module is Option Explicit, you will be told at compile time that myCalcRange has not been declared. If you omit Option Explicit, the first reference to myCalcRange will perform an implicit declaration. Detecting implicit declarations can be very difficult. Always include Option Explicit.
Issue 5
Line 11 should be If Not myCalcRange Is Nothing Then. VBA does not have an IsNot operator and the space was in the wrong place.
Issue 6
I have never used InputBox in this way and I find the help misleading:
Set myRange = Application.InputBox(prompt := "Sample", type := 8)
If you don't use the Set statement, the variable is set to the value in the range, rather than the Range object itself.
If myRange is declared as a Range then the Set is compulsory. If myRange is declared as a Variant then the Set is forbidden. If myRange is not declared and you rely on an inplicit declaration then myRange will be declared as a Range if you include Set and a Variant if you omit it.
This is not your mistake. This feature(?) of VBA is at least 11 years old and I can only assume someone thought they were being helpful.
Issue 7
7 myCalcRange.Select
8 If myCalcRange Is Nothing Then
You cannot select a range that is Nothing. The test must come first.
Issue 8
8 If myCalcRange Is Nothing Then
9 iReply = MsgBox("Range not selected!")
10 Exit Sub
11 If myCalcRange Is notNothing Then
12 Call run_CalcPeakTemp
13 End If
14 End If
With the indenting you can see that all this code is within the first If. I am not sure if this is what you wanted. Did you mean?
8 If myCalcRange Is Nothing Then
9 iReply = MsgBox("Range not selected!")
10 Exit Sub
14 End If
11 If myCalcRange Is notNothing Then
12 Call run_CalcPeakTemp
13 End If
I assume you are trying to force the user to select a range. In general, you should allow the user some way of cancelling a selection. In theory, to force the user to make a selection you need something like:
Set myCalcRange = Nothing
Do While myCalcRange Is Nothing
Set myCalcRange = Application.InputBox ...
Loop
In practice, InputBox will not permit the user to click OK unless a range has been selected and clicking Cancel gives a VBA error. InputBox( ... type := 8) is not a statement I would ever use!
Issue 9
12 Call run_CalcPeakTemp
A routine calling itself is called recursion and is permitted by VBA but it cannot be used in this way. One possible use is to search down a hierarchy and get the value at the bottom. The routine checks for being at the bottom of the hierarchy. If it is, it returns the value. If it is not, it calls itself with the next level down as its parameter.
This is the VBA equivalent of a simple use of recursion I was taught many years ago:
Function Factorial(ByVal N As Long) As Long
If N = 1 Then
Factorial = 1
Else
Factorial = N * Factorial(N - 1)
End If
End Function
This routine:
Sub Test()
Debug.Print "Factorial(1) = " & Factorial(1)
Debug.Print "Factorial(2) = " & Factorial(2)
Debug.Print "Factorial(3) = " & Factorial(3)
Debug.Print "Factorial(4) = " & Factorial(4)
Debug.Print "Factorial(5) = " & Factorial(5)
End Sub
displays the following in the immediate window:
Factorial(1) = 1
Factorial(2) = 2
Factorial(3) = 6
Factorial(4) = 24
Factorial(5) = 120
Some code that might be useful
This code matches my guess of your requirement.
I say little about the syntax of VBA I have used. In general once you know a statement exists, it is easy to look it up but ask if necessary.
I have tried explained what I am doing. I have tried to make my code as general and as maintainable as I can. There is a lot here but if you work slowly down the code I believe you will grasp what each section is doing. Again ask if necessary.
I think learning programming is like learning to driving a car. At the end of your first lesson you know you will NEVER be able to work three pedals, a gear stick, a wheel and an indicator while checking the mirror. Yet a month later you cannot remember why you found it so difficult. Welcome to the joys of programming. I hope you find it as much fun as I do.
Sub ExtractMaxTemperatures()
' I understand your temperatures are in columns 2 to 5. If I use these values
' in the code and they change (perhaps because new columns are added) then you
' will have to search the code for the appropriate 2s and 5s and replace them.
' Constants allow me to use names which makes the code easier to understand.
' Also if the column numbers change, change the constants and the code is fixed.
' I have used Sheet1 to hold the full set of temperatures and Sheet2 to hold the
' extracted maximums. In these constants, and in the variables below, replacing
' "Sht1" and "Sht2" with something more meaningful will help make the code more
' readable.
Const ColSht1TempFirst As Long = 2
Const ColSht1TempLast As Long = 5
Const RowSht1DataFirst As Long = 3
Const ColSht2Dest As Long = 2
Const RowSht2Dest As Long = 3
Dim ColSht1Crnt As Long
Dim RowSht1Crnt As Long
Dim ColSht2Crnt As Long
Dim RowSht2Crnt As Long
' Declare fixed size arrays to hold the maximum temperature
' and its row for each column
Dim TempMaxByCol(ColSht1TempFirst To ColSht1TempLast) As Single
Dim RowForMaxTemp(ColSht1TempFirst To ColSht1TempLast) As Long
Dim TempCrnt As Single
Dim TempMaxCrnt As Single
Dim RowForMaxCrnt As Long
Dim ShtValue As Variant
' It is possible to check the values within the worksheet with statements
' such as "If .Cells(RowCrnt, ColCrnt).Value = 5 Then"
' However, it is much quicker to copy all values from the worksheet to an
' array and process the values from the array. I have done this since I
' will have to use arrays within the column loop.
' I do not know the name of the worksheet containing the temperatue so I have
' used Sheet1.
' The statement "ShtValues = .UsedRange.Value" converts ShtValues to a two
' dimensional array containing every value in in the worksheet. The rows
' are dimension 1 and the columns are dimension 2 which is not the usual
' arrangement. However, it means "ShtValue(RowCrnt, ColCrnt)" matches
' ".Cells(RowCrnt, ColCrnt).Value" which avoids confusion.
' Because I have loaded the entire worksheet, row and column numbers within
' the array will match those in the worksheet.
With Worksheets("Sheet1")
ShtValue = .UsedRange.Value
End With
' Loop for each temperature column
For ColSht1Crnt = ColSht1TempFirst To ColSht1TempLast
' Your code assume no blank or non-numeric values within the temperature
' ranges. However, were they to exist, the code would fail so I check.
RowForMaxCrnt = 0 ' Indicates no temperature saved yet
' Loop for each data row column. UBound(ShtValue, 2) identifies the last row.
For RowSht1Crnt = RowSht1DataFirst To UBound(ShtValue, 1)
If IsNumeric(ShtValue(RowSht1Crnt, ColSht1Crnt)) Then
' This cell is numeric
TempCrnt = Val(ShtValue(RowSht1Crnt, ColSht1Crnt))
If RowForMaxCrnt <> 0 Then
' A possible maximum temperature has already been stored.
' Check current value against it.
If TempMaxCrnt < TempCrnt Then
' Higher temperature found. Store details in temporary variables
RowForMaxCrnt = RowSht1Crnt
TempMaxCrnt = TempCrnt
End If
Else
' First temperature found. Store details in temporary variables
RowForMaxCrnt = RowSht1Crnt
TempMaxCrnt = TempCrnt
End If
End If
Next
'Store values in temporary variable in arrays
TempMaxByCol(ColSht1Crnt) = TempMaxCrnt
RowForMaxTemp(ColSht1Crnt) = RowForMaxCrnt
Next
' Initialise the current row to the start row of the outout table
RowSht2Crnt = RowSht2Dest
' I think you call the destination sheet "Calc" but I have used "Sheet2"
With Worksheets("Sheet2")
' Create header lines
' TC1 TC2 TC3 TC4
' Max Row Max Row Max Row Max Row
' This code will handle multiple header rows
For RowSht1Crnt = 1 To RowSht1DataFirst - 1
ColSht2Crnt = ColSht2Dest
For ColSht1Crnt = ColSht1TempFirst To ColSht1TempLast
' Merge two cells together ready for column name
.Range(.Cells(RowSht2Crnt, ColSht2Crnt), _
.Cells(RowSht2Crnt, ColSht2Crnt + 1)).Merge
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = ShtValue(RowSht1Crnt, ColSht1Crnt)
.HorizontalAlignment = xlCenter
End With
ColSht2Crnt = ColSht2Crnt + 2
Next
RowSht2Crnt = RowSht2Crnt + 1
Next
' Now add "Max Row Max Row Max Row Max Row" row
ColSht2Crnt = ColSht2Dest
For ColSht1Crnt = ColSht1TempFirst To ColSht1TempLast
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = "Max"
.HorizontalAlignment = xlRight
End With
ColSht2Crnt = ColSht2Crnt + 1
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = "Row"
.HorizontalAlignment = xlRight
End With
ColSht2Crnt = ColSht2Crnt + 1
Next
RowSht2Crnt = RowSht2Crnt + 1
' Now create data row
ColSht2Crnt = ColSht2Dest
For ColSht1Crnt = ColSht1TempFirst To ColSht1TempLast
.Cells(RowSht2Crnt, ColSht2Crnt).Value = TempMaxByCol(ColSht1Crnt)
ColSht2Crnt = ColSht2Crnt + 1
.Cells(RowSht2Crnt, ColSht2Crnt).Value = RowForMaxTemp(ColSht1Crnt)
ColSht2Crnt = ColSht2Crnt + 1
Next
End With
End Sub
Edit Addition because OP wants to select columns from which maximums are to be selected.
If I understand your comment correctly:
- The number of rows is fixed at 30.
- You wish to select the columns from which the maximums are to be extracted at run-time.
The code above will handle any number of rows. I suggest you leave this unchanged even if you believe the number will always be 30. During my career I heard "that requirement could never change" many times only to hear a year or two later "Sorry, it has changed."
There was one aspect of the code above which I thought was weak but which I did not want to correct because it would have added complications that did not want to explain. I used .UsedRange to load data from the worksheet. This is the easiest method but the definition of .UsedRange does not always match what the user expects. .UsedRange includes rows and columns that have been formatted (eg height or width changed) but are otherwise unused. In this answer of mine to an earlier question I include a macro which demonstrates a number of techniques for finding the final row or column and show where each method fails. I do not think this is important for your current question but I suggest you save that macro and experiment with it later.
Consider this macro:
Sub TestGetRange()
Dim CalcRange As Range
Dim Reply As Long
Do While True
Err.Clear
On Error Resume Next
Set CalcRange = Application.InputBox(Prompt:="Select columns to be copied", _
Title:="Extract maximum temperatures", Type:=8)
On Error GoTo 0
If Err.Number <> 0 Then
Reply = MsgBox(Prompt:="Do you wish to exit without extracting any temperatures?", _
Buttons:=vbYesNo, Title:="Extract maximum temperatures")
If Reply = vbYes Then
' User wants to exit
Exit Do
End If
' Loop for another go
Else
' User had entered a valid range
Exit Do
End If
Loop
If CalcRange Is Nothing Then
Debug.Print "User wants immediate exit"
Exit Sub
Else
Debug.Print CalcRange.Address
End If
End Sub
As I said earlier, if the user clicks Cancel, there is a run time syntax error and the user has to select Debug and click F5 to continue. This is the type of situation for which On Error Resume Next is appropriate. I have added this to your original code and have included an option to exit. This macro does not use the entered range other than to display its address.
Using Ctrl+Left Mouse you can select non-contiguous ranges. You do not say if you want to be able to select columns 4, 5, 11 and 12 but, since you cannot stop the user selecting non-contiguous ranges, I have included the code to handle them.
I ran this macro a number of times. The first time I selected columns B and C, the next time I cancelled then I selected various mixed ranges. The output was:
$B:$C
User wants immediate exit
$B$1,$D$1
$B$1,$C$1,$E$1
$B$1:$D$1
$B:$B,$E:$E
$B:$C,$E:$E,$F:$F,$H:$H
$B:$B,$E$2
Notice that I get $B:$B or $B:$C if I select columns and $E$1 if I select a cell. In the last row I have selected both a column and a cell.
Have a play with this macro and get a feel for ranges that it can get from the user.
Somehow you need to convert the range obtained from the user into one or more columns.
Add this code to the bottom of the above macro:
Dim Count As Long
Dim RngCrnt As Range
Count = 0
For Each RngCrnt In CalcRange
Debug.Print " " & RngCrnt.Address
Count = Count + 1
If Count = 10 Then
Exit For
End If
Next
Debug.Print CalcRange.EntireColumn.Address
For Each RngCrnt In CalcRange.EntireColumn
Debug.Print " " & RngCrnt.Address
Count = Count + 1
If Count = 10 Then
Exit For
End If
Next
In this code I have used the For Each statement to split the range from the user into sub-ranges. I ran the macro, selected columns B and C and got the following output:
$B:$C
$B$1
$C$1
$B$2
$C$2
$B$3
$C$3
$B$4
$C$4
$B$5
$C$5
$B:$C
$B:$B
$C:$C
With the first For Next, the sub-range is a cell. If I had omitted the code limiting the output to 10, I would have got one display row per cell in each column.
In the second For Next, I have adjusted the user's range by adding .EntireColumn. This has no effect on the address as displayed by Debug.Print CalcRange.EntireColumn.Address but has changed the sub-range to a column which is what I want.
I think that is all the new information you need to understand the revised macro. I was hoping to give you a list of changes but there are too many little changes to make that practical.
Sub ExtractMaxTemperatures2()
' Adjusted to handle user selected columns
Const RowSht1DataFirst As Long = 2 ' First non-header row in Sheet1
Const ColSht2Dest As Long = 2 ' Left column \ of table of extracted
Const RowSht2Dest As Long = 3 ' Top row / values in Sheet2
Dim ColLogicalCrnt As Long ' 1, 2, 3 and so on regardless of true column number
Dim ColSht1Crnt As Long ' Current column within Sheet1
Dim ColSht2Crnt As Long ' Current column within Sheet2
Dim NumColsSelected As Long ' Number of columns selected.
Dim Reply As Long ' Return value from InputBox
Dim RowForMaxCrnt As Long ' Row holding maximum temperature found so far within current column
Dim RowSht1Crnt As Long ' Current row within Sheet1
Dim RowSht2Crnt As Long ' Current row within Sheet2
Dim RngColCrnt As Range ' Sub-range of user selected range giving current column
Dim RngUserSelected ' Range selected by user then adjusted with .EntireColumn
Dim ShtValue As Variant ' 2D array holding values loaded from Sheet1
Dim TempCrnt As Single ' The temperature from the current cell
Dim TempMaxCrnt As Single ' Maximum temperature found so far within current column
' Declare arrays to hold the maximum temperature and its row for each column.
' These arrays will be sized at runtime.
Dim TempMaxByCol() As Single ' Maximum temperature for each logical column
Dim RowForMaxTemp() As Long ' Row for maximum temperature for each logical column
With Worksheets("Sheet1")
ShtValue = .UsedRange.Value
.Activate ' Necessary to ensure Sheet1 visible for range selection
End With
Do While True
Err.Clear
On Error Resume Next
Set RngUserSelected = Application.InputBox(Prompt:="Select columns to be copied", _
Title:="Extract maximum temperatures", Type:=8)
On Error GoTo 0
If Err.Number <> 0 Then
Reply = MsgBox(Prompt:="Do you wish to exit without extracting any temperatures?", _
Buttons:=vbYesNo, Title:="Extract maximum temperatures")
If Reply = vbYes Then
' User wants to exit
Exit Do
End If
' Loop for another go
Else
' User had entered a valid range
Exit Do
End If
Loop
If RngUserSelected Is Nothing Then
Debug.Print "User wants immediate exit"
End If
' Convert any cells to columns
Set RngUserSelected = RngUserSelected.EntireColumn
' Count number of selected columns
NumColsSelected = 0
For Each RngColCrnt In RngUserSelected
NumColsSelected = NumColsSelected + 1
Next
' Size arrays for number of selected columns
ReDim TempMaxByCol(1 To NumColsSelected) As Single
ReDim RowForMaxTemp(1 To NumColsSelected) As Long
' Fill TempMaxByCol and RowForMaxTemp with extracted values
ColLogicalCrnt = 0
' Loop for each temperature column
For Each RngColCrnt In RngUserSelected
ColSht1Crnt = RngColCrnt.Column
ColLogicalCrnt = ColLogicalCrnt + 1 ' Logical column for this physical column
RowForMaxCrnt = 0 ' Indicates no temperature saved yet
' Loop for each data row column. UBound(ShtValue, 2) identifies the last row.
For RowSht1Crnt = RowSht1DataFirst To UBound(ShtValue, 1)
If IsNumeric(ShtValue(RowSht1Crnt, ColSht1Crnt)) Then
' This cell is numeric
TempCrnt = Val(ShtValue(RowSht1Crnt, ColSht1Crnt))
If RowForMaxCrnt <> 0 Then
' A possible maximum temperature has already been stored.
' Check current value against it.
If TempMaxCrnt < TempCrnt Then
' Higher temperature found. Store details in temporary variables
RowForMaxCrnt = RowSht1Crnt
TempMaxCrnt = TempCrnt
End If
Else
' First temperature found. Store details in temporary variables
RowForMaxCrnt = RowSht1Crnt
TempMaxCrnt = TempCrnt
End If
End If
Next
'Move values from temporary variables to arrays
TempMaxByCol(ColLogicalCrnt) = TempMaxCrnt
RowForMaxTemp(ColLogicalCrnt) = RowForMaxCrnt
Next
' Initialise the current row to the start row of the outout table
RowSht2Crnt = RowSht2Dest
' I think you call the destination sheet "Calc" but I have used "Sheet2"
With Worksheets("Sheet2")
' Create header lines
' TC1 TC2 TC3 TC4
' Max Row Max Row Max Row Max Row
' This code will handle multiple header rows
For RowSht1Crnt = 1 To RowSht1DataFirst - 1
ColSht2Crnt = ColSht2Dest
ColLogicalCrnt = 0
For Each RngColCrnt In RngUserSelected
ColSht1Crnt = RngColCrnt.Column
ColLogicalCrnt = ColLogicalCrnt + 1 ' Logical column for this physical column
' Merge two cells together ready for column name
.Range(.Cells(RowSht2Crnt, ColSht2Crnt), _
.Cells(RowSht2Crnt, ColSht2Crnt + 1)).Merge
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = ShtValue(RowSht1Crnt, ColSht1Crnt)
.HorizontalAlignment = xlCenter
End With
ColSht2Crnt = ColSht2Crnt + 2
Next
RowSht2Crnt = RowSht2Crnt + 1
Next
' Now add "Max Row Max Row Max Row Max Row" row
ColSht2Crnt = ColSht2Dest
' ColLogicalCrnt = 0 ' Don't need logical column for this loop
For Each RngColCrnt In RngUserSelected
ColSht1Crnt = RngColCrnt.Column
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = "Max"
.HorizontalAlignment = xlRight
End With
ColSht2Crnt = ColSht2Crnt + 1
With .Cells(RowSht2Crnt, ColSht2Crnt)
.Value = "Row"
.HorizontalAlignment = xlRight
End With
ColSht2Crnt = ColSht2Crnt + 1
Next
RowSht2Crnt = RowSht2Crnt + 1
' Now create data row
ColSht2Crnt = ColSht2Dest
ColLogicalCrnt = 0
' Loop for each temperature column
For Each RngColCrnt In RngUserSelected
' ColSht1Crnt = RngColCrnt.Column ' Don't need Sheet 1 column for this loop
ColLogicalCrnt = ColLogicalCrnt + 1 ' Logical column for this physical column
.Cells(RowSht2Crnt, ColSht2Crnt).Value = TempMaxByCol(ColLogicalCrnt)
ColSht2Crnt = ColSht2Crnt + 1
.Cells(RowSht2Crnt, ColSht2Crnt).Value = RowForMaxTemp(ColLogicalCrnt)
ColSht2Crnt = ColSht2Crnt + 1
Next
End With
End Sub
