尝试从包含特定值的单元格设置的范围中查找最大值和最小值

Question

我需要将数据从输入表提取到另一张表，如下所示

输入表：

A 栏	B 栏
2	120
2	100
2	130
2	150
-1	70
-1	200
-1	150
-1	60

到要从输入中提取的新工作表

A 栏	最大	分钟
2	150	100
-1	200	60

所以我编写了以下 VBA 代码，它不起作用，请帮忙。

Sub ExtractGeotechForces()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim sourceColumn As Range
    Dim uniqueValues As Object
    Dim cell As Range
    Dim lastRow As Long
    Dim i As Long
    
    ' Set your source and destination worksheets
    Set ws1 = ActiveSheet
    Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "ForceExtract"
    
    ' Define the source column range
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    Set sourceColumn = ws1.Range("F2:F" & lastRow)
    
    ' Create a dictionary to store unique values
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    
    ' Loop through each cell in the source column
    For Each cell In sourceColumn
        If Not uniqueValues.exists(cell.Value) Then
            uniqueValues.Add cell.Value, cell.Value
        End If
    Next cell
    
    ' Transfer unique values to the destination sheet
    ws2.Cells(1, 1).Value = "Elevation"
    i = 2
    For Each Item In uniqueValues.keys
        ws2.Cells(i, 1).Value = Item
        i = i + 1
    Next Item
    
    ' Optionally, you can sort the list alphabetically
    ws2.Sort.SortFields.Clear
    ws2.Sort.SortFields.Add Key:=ws2.Range("A2:A" & uniqueValues.Count), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ws2.Sort
        .SetRange ws2.Range("A2:A" & uniqueValues.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Dim valueToFind As Long
    Dim lastRow2 As Long
    Dim firstElevRow As Long
    Dim lastElevRow As Long
    Dim j As Long
    Dim maxValue As Double
    Dim minValue As Double
    Dim rangeToCheck As Range
    ' Define the source column range
    lastRow2 = ws2.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    For j = 2 To lastRow2
    ' Get the elvation to search
    valueToFind = ws2.Cells(j, 1).Value
    ' Find the first row with elevation
    firstElevRow = ws1.Range("F:F").Find(What:=valueToFind, After:=ws1.Cells(2, 6), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, MatchCase:=False)
    ' Find the last row with elevation
    lastElevRow = ws1.Range("F:F").Find(What:=valueToFind, After:=ws1.Cells(2, 6), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, MatchCase:=False).Row
    'For M11
        'Define the range to check
        Set rangeToCheck = ws1.Range(ws1.Cells(firstElevRow, 22), ws1.Cells(lastElevRow, 22))
        ' Find the maximum and minimum values within the range
        maxValue = Application.WorksheetFunction.Max(rangeToCheck)
        minValue = Application.WorksheetFunction.Min(rangeToCheck)
        ws2.Cells(j, 2).Value = maxValue
        ws2.Cells(j, 3).Value = minValue
    Next j
    
    MsgBox "Forces extracted successfully!"
    
End Sub

Answer 1

假设您的标签没有版本限制，您可以使用单个 Excel 公式来完成此操作：

• 根据您的数据创建一个表格并

  Name

  它

  InputTbl

• 然后在某个单元格中使用此公式：

=LET(
    hdrs, {"ColumnA", "Max", "Min"},
    colA, UNIQUE(InputTbl[ColumnA]),
    ma, BYROW(
        colA,
        LAMBDA(arr, MAXIFS(InputTbl[ColumnB], InputTbl[ColumnA], arr))
    ),
    mi, BYROW(
        colA,
        LAMBDA(arr, MINIFS(InputTbl[ColumnB], InputTbl[ColumnA], arr))
    ),
    VSTACK(hdrs, HSTACK(colA, ma, mi))
)