Excel VBA - 查找值列表的最小值？答案

【问题标题】：Excel VBA - Find minimum of list of values?Excel VBA - 查找值列表的最小值？
【发布时间】：2009-12-11 21:35:02
【问题描述】：

对于这样的列表：

Column1     Column2     Column3    
DataA       1           1234    
DataA       2           4678    
DataA       3           8910    
DataB       2           1112    
DataB       4           1314    
DataB       9           1516

如何获得这样的列表：

Column4    Column5      Column6    
DataA      1            1234    
DataB      2            1112

关键是只返回column2中的最小值及其对应column3的值。

【问题讨论】：

这是我真正想将数据放入 Access 并运行查询的 Excel 示例之一。使用GroupBy 和Min 函数可以得到你想要的东西。类似：SELECT Column1, Column2, Min(Column3) As Column3 FROM Table GROUP BY Column1。诚然，为此编写代码是一项很棒的练习，但有时使用 Access 之类的工具可能会非常有帮助。
不需要Access，Excel对ADO相当满意。
这在 Access 中会很容易 - 但工具是 Excel...ADO 示例看起来很有趣。
在 Excel 中还是很简单的。按键（A 列）和值（c 列）排序。然后在 D2 中放入 C2 的值。最后在 D3 中输入这个公式： =IF(A3A2,C3,D2) 并复制下来。复制/粘贴特殊值并收工。

标签： vba excel

【解决方案1】：

抱歉，我首先误解了您的问题。这是一个工作代码，它最终比我想要的更复杂：D

Option Explicit

Private Function inCollection(ByRef myCollection As Collection, ByRef value As Variant) As Boolean
    Dim i As Integer
    inCollection = False

    For i = 1 To myCollection.Count
        If (myCollection(i) = value) Then
            inCollection = True
            Exit Function
        End If
    Next i
End Function

Sub listMinimums()

    Dim source As Range
    Dim target As Range
    Dim row As Range
    Dim i As Integer
    Dim datas As New Collection
    Dim minRows As New Collection

    Set source = Range("A2:C5")
    Set target = Range("D2")
    target.value = source.value

    For Each row In source.Rows
        With row.Cells(1, 1)
            If (inCollection(datas, .value) = False) Then
                datas.Add .value
                minRows.Add row.row, .value
            End If
            If (Me.Cells(minRows(.value), 2) > row.Cells(1, 2)) Then
                minRows.Remove (.value)
                minRows.Add row.row, .value
            End If
        End With
    Next row

    'output'
    For i = 1 To minRows.Count
        target(i, 1) = Me.Cells(minRows(i), 1)
        target(i, 2) = Me.Cells(minRows(i), 2)
        target(i, 3) = Me.Cells(minRows(i), 3)
    Next i

    Set datas = Nothing
    Set minRows = Nothing
End Sub

注意：您可能希望将 Me 替换为工作表的名称。

【讨论】：

【解决方案2】：

使用 ADO 的示例。

Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim i As Integer

''http://support.microsoft.com/kb/246335

strFile = ActiveWorkbook.FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

cn.Open strCon

strSQL = "SELECT Column1, Min(Column3) As MinCol3 FROM [Sheet8$] GROUP BY Column1"

rs.Open strSQL, cn, 3, 3

For i = 0 To rs.fields.Count - 1
    Sheets("Sheet7").Cells(1, i + 1) = rs.fields(i).Name
Next

Worksheets("Sheet7").Cells(2, 1).CopyFromRecordset rs

【讨论】：

这似乎是一个有趣的想法，但它很慢
对于 48,000 行，我得到的结果不到一秒。

【解决方案3】：

试试这个：

Public Sub MinList()
    Const clColKey_c As Long = 1&
    Const clColVal_c As Long = 3&
    Dim ws As Excel.Worksheet, objDict As Object
    Dim lRow As Long, dVal As Double, sKey As String
    Dim lRowFrst As Long, lRowLast As Long, lColOut As Long
    Set ws = Excel.ActiveSheet
    Set objDict = CreateObject("Scripting.Dictionary")
    lRowFrst = ws.UsedRange.Row
    lRowLast = ws.UsedRange.Rows.Count
    lColOut = ws.UsedRange.Columns.Count + 1&
    For lRow = lRowFrst To lRowLast
        dVal = Val(ws.Cells(lRow, clColVal_c).Value)
        sKey = ws.Cells(lRow, clColKey_c).Value
        If objDict.Exists(sKey) Then
            If dVal > objDict.Item(sKey) Then objDict.Item(sKey) = dVal
        Else
            objDict.Add sKey, dVal
        End If
    Next
    For lRow = lRowFrst To lRowLast
        ws.Cells(lRow, lColOut).Value = objDict.Item(ws.Cells(lRow, clColKey_c).Value)
    Next
    ws.Cells(1&, lColOut).Value = "Min"
End Sub

【讨论】：