Excel VBA - 找到最小的值列表？

对于像列表：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的值。

来源

2009-12-09 John M

这是那些Excel的例子在那里我真的希望将数据扔进访问和运行查询之一。使用'GroupBy'和'Min'函数可以准确找到你要找的东西。像这样：'SELECT Column1，Column2，Min（Column3）As Column3 FROM Table GROUP BY Column1'。当然，为此编写代码是一个很好的练习，但有时使用像Access这样的工具可以对这样的事情非常有帮助。 – 2009-12-09 22:14:50

Access不需要，Excel对ADO非常满意。 – Fionnuala 2009-12-10 19:26:58

这在Access中会很容易 - 但工具是Excel ... ADO示例看起来很有趣。 – 2009-12-10 20:29:58

对不起，我首先误解了你的问题。这里是结束了，比我想这是一个比较复杂的工作代码：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。

来源

2009-12-09 21:01:31 marg

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

来源

2009-12-10 19:39:22 Fionnuala

这可能看起来像一个有趣的想法，但它非常缓慢 – vzczc 2009-12-10 21:49:57

我得到48,000行不到一秒钟。 – Fionnuala 2009-12-10 22:12:35

试试这个：

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

来源

2009-12-11 13:35:02 Oorang

Excel VBA - 找到最小的值列表？

回答

相关问题