vba - 有条件地计算动态范围中连续某些单元格的最大值(即最大数量)

Question

我正在尝试创建一个宏来查找行中特定列的最大值(即最大)。

图1:

例如，在图 1 中，我展示了一个范围从 A1 到 K12 的简单示例表。其中前两行分别代表“高度”和“年份”。而且它们总是按升序排列。该图显示了 2 年的数据，我正在尝试创建年份之间每个高度的最大值。我用红色文本突出显示了我正在尝试做的事情。例如，单元格 L3 是 B3 和 G3 的最大值(即 =MAX(B3,G3))，类似地，范围 L3:P12 中红色的所有单元格都是每个高度的最大值。我知道只需使用 Max(cell1,cell2) 函数手动计算或使用以下宏即可轻松完成此操作:

Sub test()
    Range("G1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("L1").Select
    ActiveSheet.Paste
    Range("L3").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=MAX(RC[-10],RC[-5])"
    Range("L3").Select
    Selection.AutoFill Destination:=Range("L3:P3"), Type:=xlFillDefault
    Range("L3:P3").Select
    Selection.AutoFill Destination:=Range("L3:P12")
    Range("L3:P12").Select
End Sub 

但我的实际表格要大得多，有更多年的数据和更多的高度，我将在许多电子表格中循环运行它。行数和列数可以不同。所以我只是想知道如何采用动态参数来根据前两行(即高度和年份)动态计算最大值。我在想是否可以通过任何方式为顶行设置一个范围，因为高度将始终增加，直到明年再次从最低值重新启动。我的计划是尝试设置一些条件来计算最大值并自动填充范围。但我什至无法定义范围，因为我正在努力逻辑地规划这段代码。以下是我尝试过的方法，我非常感谢任何关于如何从逻辑上解决这个问题的指导。提前谢谢了!

Sub test()
Dim LR As Long, i As Long, r As Range
LR = Range("1" & Columns.Count).End(xlToRight)
For i = 1 To LR
    If Range("1" & i).Value > 10 Then
        If r Is Nothing Then
            Set r = Range("1" & i)
        Else
            Set r = Union(r, Range("1" & i))
        End If
    End If
Next i
r.Select
End Sub

Answer 1

由于高度值的无限可能性，使用类是我目前能想到的最佳解决方案。希望这为构建提供了良好的基础。

在名为“HeightClass”的类模块中:

Option Explicit

Dim rngRangeStore As Range
Dim sValueStore As String

Public Property Set rngRange(rngInput)
    Set rngRangeStore = rngInput
End Property

Public Property Get rngRange() As Range
    Set rngRange = rngRangeStore
End Property

Public Property Let sValue(sInput As String)
    sValueStore = sInput
End Property

Public Property Get sValue() As String
    sValue = sValueStore
End Property

然后在标准模块中:

Option Explicit

Sub Get_Max()
Dim lRecord As Long, lRange As Long, lLastRecord As Long, lLastColumn As Long
Dim colRanges As New Collection
Dim clsRange As HeightClass

    'Find Last used column in the year row
    lLastColumn = Rows(2).Find(What:="*", SearchDirection:=xlPrevious).Column
    'Find last used row in column 1
    lLastRecord = Columns(1).Find(What:="*", SearchDirection:=xlPrevious).Row
    For lRange = 2 To lLastColumn
        On Error Resume Next
        Set clsRange = Nothing
        Set clsRange = colRanges(Trim$(Cells(1, lRange).Value))
        On Error GoTo 0
        If Not clsRange Is Nothing Then

            'Add to existing range
            Set clsRange.rngRange = Union(clsRange.rngRange, Cells(1, lRange))
        Else

            'Add range to colletion in order of smallest to largest
            Set clsRange = New HeightClass
            Set clsRange.rngRange = Cells(1, lRange)
            clsRange.sValue = Cells(1, lRange).Value
            If colRanges.Count = 0 Then
                colRanges.Add Item:=clsRange, Key:=clsRange.sValue
            Else
                For lRecord = 1 To colRanges.Count
                    If clsRange.sValue < colRanges(lRecord).sValue Then
                        colRanges.Add Item:=clsRange, Key:=clsRange.sValue, Before:=colRanges(lRecord).sValue
                        Exit For
                    ElseIf lRecord = colRanges.Count Then
                        colRanges.Add Item:=clsRange, Key:=clsRange.sValue, After:=colRanges(lRecord).sValue
                        Exit For
                    End If
                Next lRecord
            End If
        End If
    Next lRange

    'Place height headers
    For lRange = 1 To colRanges.Count
        With Cells(1, lLastColumn + lRange)
            .Value = colRanges(lRange).sValue
            .Font.Color = vbRed
        End With
    Next lRange

    'Process each record
    For lRecord = 3 To lLastRecord
        For lRange = 1 To colRanges.Count
            With Cells(lRecord, lLastColumn + lRange)
                .Value = Application.Max(colRanges(lRange).rngRange.Offset(lRecord - 1))
                .Font.Color = vbRed
                .NumberFormat = "0.00"
            End With
        Next lRange
    Next lRecord
End Sub

编写此代码是为了在焦点所在的任何工作表上执行所需的过程。