Question

列表如下：

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列中的最小值及其对应的列值。

Answer 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替换为工作表的名称。

Answer 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

Answer 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

Excel VBA - 查找最少的值列表？

3 个答案: