Excel VBA-查找最小值列表？

对于以下列表：

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

---

关键是只返回第2列中的最小值及其对应的第3列值。

对不起，我首先误解了您的问题。下面是一个比我想要的更复杂的工作代码：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

。

对不起，我先误解了您的问题。下面是一个比我想要的更复杂的工作代码：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

。

使用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

一个使用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

试试这个：

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

试试这个：

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

---

这是其中一个Excel示例，我真的希望将数据放入Access并运行查询。使用

GroupBy

和

Min

函数将获得您想要的内容。类似于：

从表GROUP BY Column1中选择Column1、Column2、Min（Column3）作为Column3

。诚然，为此编写代码是一个很好的练习，但有时使用Access之类的工具对这样的事情非常有帮助。不需要Access，Excel对ADO非常满意。这在Access中很容易-但该工具是Excel。。。ADO示例看起来很有趣。在Excel中仍然很简单。按键（A列）和值（c列）排序。然后在D2中输入C2的值。最后在D3中输入公式：=IF（A3A2，C3，D2）并复制下来。复制/粘贴特殊值并结束。这是一个Excel示例，我真的希望将数据放入Access并运行查询。使用

GroupBy

和

Min

函数将获得您想要的内容。类似于：

从表GROUP BY Column1中选择Column1、Column2、Min（Column3）作为Column3

。诚然，为此编写代码是一个很好的练习，但有时使用Access之类的工具对这样的事情非常有帮助。不需要Access，Excel对ADO非常满意。这在Access中很容易-但该工具是Excel。。。ADO示例看起来很有趣。在Excel中仍然很简单。按键（A列）和值（c列）排序。然后在D2中输入C2的值。最后在D3中输入公式：=IF（A3A2，C3，D2）并复制下来。复制/粘贴特殊值并结束。这似乎是一个有趣的想法，但对于48000行来说，这是一个非常慢的想法。这似乎是一个有趣的想法，但对于48000行来说，这是一个非常慢的想法，因为它的时间不到一秒。