通过 VBA 数组函数从包含特定值的单元格设置的范围中查找最大值和最小值

Question

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

输入表： 我添加了要从中提取数据的源文件的图像 我隐藏了一些列，以便只有我想从中提取数据的列才是可见的

从源文件的图像列 F 中可以看出，有许多重复值，例如 10 行的值为 2，但在相应行的其他列中具有不同的值。

我想将其他列数据（G J M P S V Y AB）分组到 F 列（例如 2）上的单个键值，并找到每列的最大值和最小值，并将其提取到新工作表中，如下所示

我修改了一些代码，这些代码从这个论坛获得了帮助，仅提取两列的类似数据，如下所示

Sub ExtractGeotechForces3()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long
    Dim arr, arrFin(), arrIt
    Dim i As Long, dict As Object
    
    Set ws1 = ActiveSheet
    Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "ForceExtract"
    
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    arr = ws1.Range("F2:AD" & lastRow).Value2
    
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23))
        Else
            arrIt = dict(arr(i, 1))
            ReDim Preserve arrIt(UBound(arrIt) + 1)
            arrIt(UBound(arrIt)) = Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23))
            dict(arr(i, 1)) = arrIt
        End If
    Next i
    
    ' Adjust the size of arrFin to accommodate additional columns
    ReDim arrFin(1 To dict.Count, 1 To 15) ' 1 for elevation, 7 for max, and 7 for min
    
    Dim key As Variant, values As Variant
    For i = 1 To dict.Count
        key = dict.keys()(i - 1)
        values = dict(key)
        arrFin(i, 1) = key ' Place the key in the output array
        
        ' Loop through the values array to extract max and min for each column
        Dim j As Long, k As Long
        For j = 0 To UBound(values)
            ' Calculate maximum and minimum values for each column
            For k = 1 To 7
                arrFin(i, k * 2) = WorksheetFunction.Max(values(j)) ' Max value
                arrFin(i, k * 2 + 1) = WorksheetFunction.Min(values(j)) ' Min value
            Next k
        Next j
    Next i
    
    ' Output the results to the destination worksheet
    ws2.Range("A1").Resize(, 15).Value = Array("Elevation", "N1-Max", "N1-Min", "N2-Max", "N2-Min", "Q12-Max", "Q12-Min", "Q23-Max", "Q23-Min", "Q13-Max", "Q13-Min", "M11-Max", "M11-Min", "M22-Max", "M22-Min", "M13-Max", "M13-Min") ' Column headers
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin ' Processed values
End Sub

现在我想将其扩展到多列，但是当我尝试运行程序时，所有提取的列都会重复同一列的最大值和最小值

Answer 1

您的代码即将完成。

• Dict 中的第一项应添加

  Array(Array(arr(i, 2), arr(i, 8)...))

  。
• 数据按行添加到字典中。您的目标是找到列中的最大值或最小值。因此添加一个

  For

  循环来提取

  arrCol

  。

Option Explicit
Sub ExtractGeotechForces3()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow As Long
    Dim arr, arrFin(), arrIt
    Dim i As Long, dict As Object
    Set ws1 = ActiveSheet
    On Error Resume Next
    Set ws2 = Sheets("ForceExtract")
    On Error GoTo 0
    If ws2 Is Nothing Then
        Set ws2 = ThisWorkbook.Worksheets.Add
        ws2.Name = "ForceExtract"
    Else
        ws2.Cells.Clear
    End If
    lastRow = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
    arr = ws1.Range("F2:AD" & lastRow).Value2
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(arr)
        If Not dict.Exists(arr(i, 1)) Then
            dict.Add arr(i, 1), Array(Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23)))
        Else
            arrIt = dict(arr(i, 1))
            ReDim Preserve arrIt(UBound(arrIt) + 1)
            arrIt(UBound(arrIt)) = Array(arr(i, 2), arr(i, 8), arr(i, 11), arr(i, 14), arr(i, 17), arr(i, 20), arr(i, 23))
            dict(arr(i, 1)) = arrIt
        End If
    Next i
    ' Adjust the size of arrFin to accommodate additional columns
    ReDim arrFin(1 To dict.Count, 1 To 15) ' 1 for elevation, 7 for max, and 7 for min
    Dim key As Variant, values As Variant, arrCol
    ReDim arrCol(1 To 7)
    For i = 1 To dict.Count
        key = dict.keys()(i - 1)
        values = dict(key)
        arrFin(i, 1) = key ' Place the key in the output array
        ' Loop through the values array to extract max and min for each column
        Dim j As Long, k As Long, s As Long, iCnt As Long
        For j = 0 To UBound(values)
            ' Calculate maximum and minimum values for each column
            For k = 1 To 7
                iCnt = UBound(values) + 1
                ReDim arrCol(1 To iCnt)
                For s = 1 To iCnt
                    arrCol(s) = values(s - 1)(k - 1)
                Next
                arrFin(i, k * 2) = WorksheetFunction.Max(arrCol) ' Max value
                arrFin(i, k * 2 + 1) = WorksheetFunction.Min(arrCol) ' Min value
            Next k
        Next j
    Next i
    ' Output the results to the destination worksheet
    ws2.Range("A1").Resize(, 15).Value = Array("Elevation", "N1-Max", "N1-Min", "N2-Max", "N2-Min", "Q12-Max", "Q12-Min", "Q23-Max", "Q23-Min", "Q13-Max", "Q13-Min", "M11-Max", "M11-Min", "M22-Max", "M22-Min", "M13-Max", "M13-Min") ' Column headers
    ws2.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value2 = arrFin ' Processed values
End Sub