Excel VBA - 查找值列表的最小值?
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/1876506/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA - Find minimum of list of values?
提问by John M
For a list like:
对于像这样的列表:
Column1 Column2 Column3
DataA 1 1234
DataA 2 4678
DataA 3 8910
DataB 2 1112
DataB 4 1314
DataB 9 1516
How do I get a list like this:
我如何获得这样的列表:
Column4 Column5 Column6
DataA 1 1234
DataB 2 1112
The key is to only return the minimum value in column2 and its corresponding column3 value.
关键是只返回 column2 中的最小值及其对应的 column3 值。
回答by marg
Sorry I misunderstood your Question First. Here is a working code that ended up more complex than I wanted it to be :D
抱歉,我首先误解了您的问题。这是一个工作代码,最终比我想要的更复杂: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
Note: You might want to replace Me
with the name of your sheet.
注意:您可能想要替换Me
为您的工作表的名称。
回答by Fionnuala
An example using ADO.
使用 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
回答by Oorang
Try this:
尝试这个:
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