动态范围中每列的最大值

I have "sheet 1" with raw data. The number of rows and columns is always different. The columns show temperatures varying function of time. As is showed:

我有原始数据的“表1”。行数和列数总是不同的。列显示温度随时间变化的函数。如图所示:

ColumnA (time) 0.000/Column B (TC1) 27.342/Column C (TC2) 26.409/Column D (TC3) ...etc.

ColumnA(时间)0.000 / B栏(TC1)27.342 / C栏(TC2)26.409 / D栏(TC3)......等。

I would like to find the maximum value in each temperature column and copy and paste them transpose on "sheet2", pasting also its first row, and matching the peak temp with its row, as is showed below:

我想在每个温度列中找到最大值,并将它们复制并粘贴到“sheet2”上,粘贴它的第一行,并将峰值温度与其行匹配,如下所示:

TC1 305.387(max value) 354 (row)/TC2 409.989(max value) 575 (row)/TC3 789.383(max temp) 899(row)...etc.

TC1 305.387(最大值)354(行)/ TC2 409.989(最大值)575(行)/ TC3 789.383(最大温度)899(行)......等。

The point is that I'm using my own range...each time that I use the code I choose different range, sometimes includes all the rows and some columns, other times some rows and all columns, etc. Below is myRange code:

关键是我正在使用自己的范围...每次我使用代码时我选择不同的范围,有时包括所有行和一些列,有时包括一些行和所有列等。下面是myRange代码:

Public Sub run_CalcPeakTemp()
Dim myCalRange As Range
Dim iReply As Integer
On Error Resume Next
Set myCalcRange = Application.InputBox(Prompt:="Select first row and then Ctrl+Shift+down", Title:="Select Range", Type:=8)
myCalcRange.Select
If myCalcRange Is Nothing Then
iReply = MsgBox("Range not selected!")
Exit Sub
If myCalcRange Is notNothing Then
Call run_CalcPeakTemp
End If
End If

And here is where I'm stuck...I'm not able of doing it in a loop. I did badly a too basic like that...step by step...I'm a beginner :(

这就是我被困住的地方......我无法在循环中做到这一点。我做得非常糟糕......一步一步......我是初学者:(

Dim VarMaxVal As Variant
VarMaxVal = 0
VarMaxVal = Application.WorksheetFunction.Max(Columns(1))
Sheets("Calc").Select
Range("A1").Select
ActiveCell.Offset(1, 2).Range("A1").Select
ActiveCell.FormulaR1C1 = VarMaxVal

And so on the rest of the columns.

其他列也是如此。

.....Nether I was able of copy the first row of my dynamic range selected.

.....虚空我能够复制我选择的动态范围的第一行。

1 个解决方案

#1

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.

当存在合适的工作表函数时,使用工作表函数而不是自己的VBA是绝对正确的,因为工作表函数将大大加快。但是,如果有任何方法让Max函数返回行,我不知道。我相信你必须使用VBA来扫描每一列。

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:

On Error Resume Next永远不应该像这样使用,因为所有错误都将被忽略。理想情况下,您可以提前检查以避免错误。如果要打开文件,则应在尝试打开之前检查它是否存在,而不是等待打开失败并给出错误。但是,在某些情况下您无法检查错误。在这种情况下,您可以使用On Error Resume Next,这样:

  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.

我添加了行号,以便我可以轻松地引用语句。我还将第5行分成两行,因此大部分都是可见的。

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.

在第2行,您声明myCalRange。在例程中的其他地方,您使用myCalcRange。如果模块的第一个语句是Option Explicit,则在编译时将告知您尚未声明myCalcRange。如果省略Option Explicit,则对myCalcRange的第一个引用将执行隐式声明。检测隐式声明可能非常困难。始终包含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.

第11行应该是如果不是myCalcRange则没有。 VBA没有IsNot运算符,空格位置错误。

Issue 6

I have never used InputBox in this way and I find the help misleading:

我从来没有以这种方式使用过InputBox,我发现这些帮助有误导性:

• Set myRange = Application.InputBox(prompt := "Sample", type := 8)

  设置myRange = Application.InputBox(prompt:=“Sample”,输入:= 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.

  如果不使用Set语句,则将变量设置为范围中的值,而不是Range对象本身。

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.

如果myRange被声明为Range,那么Set是强制的。如果myRange被声明为Variant,则禁止使用Set。如果未声明myRange并依赖于隐式声明,则如果包含Set,则将myRange声明为Range,如果省略则将声明为Variant。

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.

这不是你的错。 VBA的这个功能(?)至少有11年的历史,我只能假设有人认为他们有所帮助。

Issue 7

 7   myCalcRange.Select
 8   If myCalcRange Is Nothing Then

You cannot select a range that is Nothing. The test must come first.

您无法选择Nothing范围。测试必须先行。

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?

通过缩进,您可以看到所有这些代码都在第一个If中。我不确定这是不是你想要的。你的意思是?

 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!

在实践中,InputBox不允许用户单击“确定”,除非已选择范围并单击“取消”会发出VBA错误。 InputBox(... type:= 8)不是我用过的语句!

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.

一个例程调用本身称为递归,并且VBA允许它,但它不能以这种方式使用。一种可能的用法是向下搜索层次结构并获取底部的值。例程检查是否位于层次结构的底部。如果是,则返回该值。如果不是,它会将下一级别作为参数调用自身。

This is the VBA equivalent of a simple use of recursion I was taught many years ago:

这是VBA相当于我多年前教过的简单使用递归:

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.

我对我使用的VBA的语法几乎没有说。一般情况下,一旦你知道一个陈述存在,就很容易查找,但是如果有必要的话。

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.

编辑添加因为OP想要选择要从中选择最大值的列。

If I understand your comment correctly:

如果我理解你的评论:

• The number of rows is fixed at 30.

行数固定为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."

上面的代码将处理任意数量的行。我建议你保持不变,即使你认为这个数字永远是30。在我的职业生涯中,我听到“这个要求永远不会改变”很多次只是听了一两年后“对不起,它已经改变了。”

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.

上面的代码有一个方面,我认为它很弱,但我不想纠正,因为它会增加不想解释的复杂性。我使用.UsedRange从工作表加载数据。这是最简单的方法,但.UsedRange的定义并不总是与用户期望的相匹配。 .UsedRange包括已格式化的行和列(例如,高度或宽度已更改)但未使用。在我对早期问题的回答中,我包含了一个宏,它演示了许多用于查找最终行或列的技术,并显示了每个方法失败的位置。我不认为这对您当前的问题很重要,但我建议您保存该宏并稍后进行实验。

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.

正如我之前所说,如果用户单击“取消”,则会出现运行时语法错误,用户必须选择“调试”并单击“F5”才能继续。这是On Error Resume Next适合的情况类型。我已将此添加到您的原始代码中并包含退出选项。除了显示其地址外,此宏不使用输入的范围。

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.

使用Ctrl +鼠标左键可以选择非连续范围。您没有说您是否希望能够选择第4,5,11和12列,但是,由于您无法阻止用户选择不连续的范围,因此我已经包含了处理它们的代码。

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列时,下次取消时我选择了各种混合范围。输出是:

$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.

请注意,如果我选择列,我会得到$ B:$ B或$ B:$ C,如果我选择一个单元,则得$ E $ 1。在最后一行中,我选择了一列和一个单元格。

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:

在这段代码中,我使用For Each语句将范围从用户拆分为子范围。我运行了宏,选择了列B和C,得到了以下输出:

$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.

使用第一个For Next,子范围是一个单元格。如果我省略了将输出限制为10的代码,那么每列中每个单元格会有一个显示行。

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.

在第二个For Next中,我通过添加.EntireColumn来调整用户的范围。这对Debug.Print CalcRange.EntireColumn.Address显示的地址没有影响,但已将子范围更改为我想要的列。

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