Excel 动态范围中每列的最大值
我有带原始数据的“表1”。行数和列数总是不同的。这些列显示温度随时间变化的函数。如图所示： A列（时间）0.000/B列（TC1）27.342/C列（TC2）26.409/D列（TC3） 我希望在每个温度列中找到最大值，并将其复制并粘贴到“sheet2”上，同时粘贴其第一行，并将峰值温度与其行匹配，如下所示： TC1 305.387（最大值）354（世界其他地区）/TC2 409.989（最大值）575（世界其他地区）/TC3 789.383（最大温度）899（世界其他地区）等 关键是我在使用自己的范围…每次使用代码时，我都会选择不同的范围，有时包括所有行和一些列，有时包括一些行和所有列，等等。下面是我的范围代码：Excel 动态范围中每列的最大值,excel,dynamic,range,vba,Excel,Dynamic,Range,Vba,我有带原始数据的“表1”。行数和列数总是不同的。这些列显示温度随时间变化的函数。如图所示： A列（时间）0.000/B列（TC1）27.342/C列（TC2）26.409/D列（TC3） 我希望在每个温度列中找到最大值，并将其复制并粘贴到“sheet2”上，同时粘贴其第一行，并将峰值温度与其行匹配，如下所示： TC1 305.387（最大值）354（世界其他地区）/TC2 409.989（最大值）575（世界其他地区）/TC3 789.383（最大温度）899（世界其他地区）等 关键是我在使用自
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
错误恢复下一步，因此：
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
我添加了行号，这样我可以很容易地引用语句。我还将第5行拆分为两行，这样大部分内容都是可见的
第4期
在第2行，您声明了myCalRange
。在例程中的其他地方，您使用了myCalcRange
。如果模块的第一条语句是Option Explicit
，您将在编译时被告知未声明myCalcRange
。如果省略Option Explicit
，则第一条对myCa的引用lcRange
将执行隐式声明。检测隐式声明可能非常困难。始终包括选项Explicit
第5期
第11行应该是如果不是myCalcRange则为Nothing
。VBA没有IsNot运算符，并且空格位置错误
第6期
我从未以这种方式使用过InputBox，我发现其帮助有误导性：
- 设置myRange=Application.InputBox（提示：=“示例”，类型：=8）
- 如果不使用Set语句，则将变量设置为范围中的值，而不是范围对象本身
如果myRange
被声明为Range
，则Set
是强制的。如果myRange
被声明为变体，则Set
是禁止的。如果myRange
未被声明且您依赖于非法声明，则myRange
将被声明为范围如果包含设置
和变量
如果省略它
这不是你的错。VBA的这个功能（？）至少有11年的历史了，我只能假设有人认为他们很有帮助
第7期
7 myCalcRange.Select
8 If myCalcRange Is Nothing Then
您不能选择一个不存在的范围。必须先进行测试
第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
通过缩进，您可以看到所有这些代码都在第一个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
我假设您试图强制用户选择一个范围。一般来说，您应该允许用户以某种方式取消选择。理论上，要强制用户进行选择，您需要以下内容：
Set myCalcRange = Nothing
Do While myCalcRange Is Nothing
Set myCalcRange = Application.InputBox ...
Loop
实际上，InputBox将不允许用户单击“确定”，除非选择了一个范围，并且单击“取消”会出现VBA错误。InputBox（…type:=8）
不是我会使用的语句
第9期
12 Call run_CalcPeakTemp
一个例程调用本身被称为递归，它是由VBA允许的，但它不能以这种方式使用。一个可能的用途是搜索层次结构并在底部获取值。例程检查位于层次结构的底部。如果是，则返回值。如果不是，则调用它自己的下一级作为它的PAR。阿米特
这是我多年前学习的递归的简单用法的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
此例行程序：
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
在即时窗口中显示以下内容：
Factorial(1) = 1
Factorial(2) = 2
Factorial(3) = 6
Factorial(4) = 24
Factorial(5) = 120
一些可能有用的代码
此代码符合我对您的需求的猜测
我很少提到我使用的VBA语法。一般来说，一旦你知道一个语句存在，就可以很容易地查找它，但如果有必要，可以询问
我已经试着解释了我在做什么。我已经试着让我的代码尽可能的通用和可维护。这里有很多东西，但是如果你慢慢地写代码，我相信你会理解每个部分在做什么。如果必要的话，再问一次
我认为学习编程就像学习驾驶汽车。在第一节课结束时，你知道你永远无法在检查镜子时使用三个踏板、一个变速杆、一个车轮和一个指示器。然而一个月后，你就不能了
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
Factorial(1) = 1
Factorial(2) = 2
Factorial(3) = 6
Factorial(4) = 24
Factorial(5) = 120
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
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
$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
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
$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
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