如何确定VBA数组中子组的最大值
How to determine the MAX value of a sub-group in a VBA Array
我的歉意：下面的代码片段可能会导致我从工作表中工作时出错 - 我从工作表中获取代码中的值只是为了简化代码。 VALUES 来自 ADODB 数据集，然后将其复制到数组中。这些值将保留在内存中，不会使用任何工作表来获得最终结果。很抱歉没有从一开始就指定它。
我有一个二维数组，我正在尝试获取每个唯一 ID 的 MAX(VALUE)
ID
VALUE
DATA
101
10
1125
101
8
2546
101
11
1889
102
5
3521
102
10
2254
103
11
3544
最终结果应该是具有唯一 ID 的 finalArr：
ID
VALUE
DATA
101
11
1889
102
10
2254
103
11
3544
到目前为止我有：
我确实设法在特定维度（值）中找到了 MAX
Sub MX_Value()
Dim dataArr, iMax As Long, iCount As Long, tmpArr() As Integer, MyDim As Integer
Dim i As Integer
'*NOTE: Values from worksheet is an example only
'in real-life the data comes from an ADODB dataset
'so i need code that works in memory only.
dataArr = ThisWorkbook.Sheets(1).[A1:C6].Value
ReDim tmpAr(1 To UBound(dataArr))
MyDim = 2 'Desired Dimension, 1 to 2
For i = 1 To UBound(dataArr)
tmpAr(i) = dataArr(i, MyDim)
Next
iMax = WorksheetFunction.Max(tmpAr)
iCount = WorksheetFunction.Match(iMax, tmpAr, 0)
MsgBox "MAX value is in dataArr(" & iCount & ") - with data: " & dataArr(iCount, 1) & " - " & dataArr(iCount, 2) & " - " & dataArr(iCount, 3)
End Sub
但我不知道如何对各个 ID 进行分组以找到它们的 MAX。我能想到的唯一逻辑是：
- 获取第一个 ID，然后将具有相同 ID 的所有行添加到一个 tempArr
- 将 tempArr 发送到函数以获取 MAX 并将 MAX 行复制到 finalArr
- 转到下一个与上一个 ID 不匹配的 ID 并重新开始... [???]
注意：代码示例中的数据来自工作表，只是为了简化代码。在它的实际应用程序中，数组中的数据来自 ADODB 数据集 - 所以一切都必须在内存中完成
任何见解将不胜感激！
获取每个唯一值的最大值
- 字典会将唯一值作为其
key，并将最高值的行作为对应的 item。在循环时，它将使用此项来比较第二列的值并相应地修改它。最后，另一个循环将结果写入同一个数组，该数组将部分复制到目标范围。
- 假定一行 headers。如果您不想要 headers，则根据需要更改
sfcAddress，并更改 For r = 1 to srCount 和 r = 0。
Option Explicit
Sub MaxOfUnique()
Const sName As String = "Sheet1"
Const sfcAddress As String = "A1"
Const dName As String = "Sheet1"
Const dfcAddress As String = "E1"
Const cCount As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sfcAddress)
Dim srg As Range
With sfCell.CurrentRegion
Set srg = sfCell.Resize(.Row + .Rows.Count _
- sfCell.Row, .Column + .Columns.Count - sfCell.Column)
End With
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then Exit Sub
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 2 To srCount
If dict.Exists(Data(r, 1)) Then
If Data(r, 2) > Data(dict(Data(r, 1)), 2) Then
dict(Data(r, 1)) = r
End If
Else
dict(Data(r, 1)) = r
End If
Next r
Dim Key As Variant
r = 1
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = Data(dict(Key), 2)
Data(r, 3) = Data(dict(Key), 3)
Next Key
With wb.Worksheets(dName).Range(dfcAddress).Resize(, cCount)
.Resize(r).Value = Data ' write
.Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear ' below
End With
End Sub
您可以使用字典来跟踪最大值，请参见下面的示例。
这是名为“记录”的 class 模块
Public id As Integer
Public value As Integer
Public data As Integer
这是我在 sheet
上连接的按钮点击代码
Sub Button3_Click()
Dim dict 'Create a variable
Set dict = CreateObject("Scripting.Dictionary")
Dim dataArr() As Variant
Dim id, value, data As Integer
dataArr = Range("A2:C7").value
Dim rec As Record
For i = 1 To UBound(dataArr)
id = dataArr(i, 1)
value = dataArr(i, 2)
data = dataArr(i, 3)
If (dict.Exists(id)) Then
Set rec = dict(id)
' if value is greater, then update it in dictionary for this id
If (value > rec.value) Then
dict.Remove (rec.id)
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Else
' this is an id we haven't seen before, so add rec to dictionary
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Next
' print results
Dim result As String
For Each id In dict.Keys()
Set rec = dict(id)
result = result & "id = " & id & ", maxValue = " & rec.value & ", data = " & rec.data & vbCrLf
Next
MsgBox (result)
End Sub
我的歉意：下面的代码片段可能会导致我从工作表中工作时出错 - 我从工作表中获取代码中的值只是为了简化代码。 VALUES 来自 ADODB 数据集，然后将其复制到数组中。这些值将保留在内存中，不会使用任何工作表来获得最终结果。很抱歉没有从一开始就指定它。
我有一个二维数组，我正在尝试获取每个唯一 ID 的 MAX(VALUE)
| ID | VALUE | DATA |
|---|---|---|
| 101 | 10 | 1125 |
| 101 | 8 | 2546 |
| 101 | 11 | 1889 |
| 102 | 5 | 3521 |
| 102 | 10 | 2254 |
| 103 | 11 | 3544 |
最终结果应该是具有唯一 ID 的 finalArr：
| ID | VALUE | DATA |
|---|---|---|
| 101 | 11 | 1889 |
| 102 | 10 | 2254 |
| 103 | 11 | 3544 |
到目前为止我有： 我确实设法在特定维度（值）中找到了 MAX
Sub MX_Value()
Dim dataArr, iMax As Long, iCount As Long, tmpArr() As Integer, MyDim As Integer
Dim i As Integer
'*NOTE: Values from worksheet is an example only
'in real-life the data comes from an ADODB dataset
'so i need code that works in memory only.
dataArr = ThisWorkbook.Sheets(1).[A1:C6].Value
ReDim tmpAr(1 To UBound(dataArr))
MyDim = 2 'Desired Dimension, 1 to 2
For i = 1 To UBound(dataArr)
tmpAr(i) = dataArr(i, MyDim)
Next
iMax = WorksheetFunction.Max(tmpAr)
iCount = WorksheetFunction.Match(iMax, tmpAr, 0)
MsgBox "MAX value is in dataArr(" & iCount & ") - with data: " & dataArr(iCount, 1) & " - " & dataArr(iCount, 2) & " - " & dataArr(iCount, 3)
End Sub
但我不知道如何对各个 ID 进行分组以找到它们的 MAX。我能想到的唯一逻辑是：
- 获取第一个 ID，然后将具有相同 ID 的所有行添加到一个 tempArr
- 将 tempArr 发送到函数以获取 MAX 并将 MAX 行复制到 finalArr
- 转到下一个与上一个 ID 不匹配的 ID 并重新开始... [???]
注意：代码示例中的数据来自工作表，只是为了简化代码。在它的实际应用程序中，数组中的数据来自 ADODB 数据集 - 所以一切都必须在内存中完成
任何见解将不胜感激！
获取每个唯一值的最大值
- 字典会将唯一值作为其
key，并将最高值的行作为对应的item。在循环时，它将使用此项来比较第二列的值并相应地修改它。最后，另一个循环将结果写入同一个数组，该数组将部分复制到目标范围。 - 假定一行 headers。如果您不想要 headers，则根据需要更改
sfcAddress，并更改For r = 1 to srCount和r = 0。
Option Explicit
Sub MaxOfUnique()
Const sName As String = "Sheet1"
Const sfcAddress As String = "A1"
Const dName As String = "Sheet1"
Const dfcAddress As String = "E1"
Const cCount As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sfcAddress)
Dim srg As Range
With sfCell.CurrentRegion
Set srg = sfCell.Resize(.Row + .Rows.Count _
- sfCell.Row, .Column + .Columns.Count - sfCell.Column)
End With
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then Exit Sub
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 2 To srCount
If dict.Exists(Data(r, 1)) Then
If Data(r, 2) > Data(dict(Data(r, 1)), 2) Then
dict(Data(r, 1)) = r
End If
Else
dict(Data(r, 1)) = r
End If
Next r
Dim Key As Variant
r = 1
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = Data(dict(Key), 2)
Data(r, 3) = Data(dict(Key), 3)
Next Key
With wb.Worksheets(dName).Range(dfcAddress).Resize(, cCount)
.Resize(r).Value = Data ' write
.Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear ' below
End With
End Sub
您可以使用字典来跟踪最大值，请参见下面的示例。
这是名为“记录”的 class 模块
Public id As Integer
Public value As Integer
Public data As Integer
这是我在 sheet
上连接的按钮点击代码Sub Button3_Click()
Dim dict 'Create a variable
Set dict = CreateObject("Scripting.Dictionary")
Dim dataArr() As Variant
Dim id, value, data As Integer
dataArr = Range("A2:C7").value
Dim rec As Record
For i = 1 To UBound(dataArr)
id = dataArr(i, 1)
value = dataArr(i, 2)
data = dataArr(i, 3)
If (dict.Exists(id)) Then
Set rec = dict(id)
' if value is greater, then update it in dictionary for this id
If (value > rec.value) Then
dict.Remove (rec.id)
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Else
' this is an id we haven't seen before, so add rec to dictionary
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Next
' print results
Dim result As String
For Each id In dict.Keys()
Set rec = dict(id)
result = result & "id = " & id & ", maxValue = " & rec.value & ", data = " & rec.data & vbCrLf
Next
MsgBox (result)
End Sub