VBA -创建数组的唯一值和求和对应的值

Question

我正在寻找VBA问题的一些帮助。基本上，我是从sheet1上的源文件收集信息到静态数组中。从这些静态数组中，我创建了一个带有帐号和计算值的动态数组。我接下来要做的是创建第二个动态数组，其中只有唯一的帐号，并将前一个动态数组中的计算值求和。但是我不知道该怎么做……

以下是我目前掌握的信息。

Dim ClosingCash() As Variant, MarginExcess() As Variant, VarMarg() As Variant, Acct() As Variant, FX() As Variant, UniqueAcct() As Variant, Answers() As Variant
Dim Dim1 As Long, Counter As Long, W_Sum As Long
Sheet1.Activate
Acct = Range("b2", Range("b2").End(xlDown))
ClosingCash = Range("f2", Range("f2").End(xlDown))
MarginExcess = Range("j2", Range("J2").End(xlDown))
FX = Range("n2", Range("n2").End(xlDown))
VarMarg = Range("o2", Range("o2").End(xlDown))
Dim1 = UBound(ClosingCash, 1)
ReDim Answers(1 To Dim1, 1 To 2)
For Counter = 1 To Dim1
Answers(Counter, 1) = Acct(Counter, 1)
Answers(Counter, 2) = (WorksheetFunction.Min(ClosingCash(Counter, 1) + VarMarg(Counter, 1), MarginExcess(Counter, 1)) * FX(Counter, 1))
Next Counter
Sheet3.Activate
Range("a2", Range("a2").Offset(Dim1 - 1, 1)).Value = Answers

我想打印出的是唯一的帐号，以及与该帐号对应的答案(counter, 2)的和，类似于SumIf。

任何建议将不胜感激!

Answer 1

Sum Unique

• 在你的代码中你可以这样使用:

  Dim Data As Variant: Data = getUniqueSum(Answers)
  If Not IsEmpty(Data) Then       
  Sheet3.Range("E2").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
  End If
  

代码

Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from the first column of a 2D array
'               and the sum of the corresponding values in its second column,
'               to a 2D one-based two-columns array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueSum( _
Data As Variant) _
As Variant
If IsEmpty(Data) Then Exit Function
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim i As Long
Dim c1 As Long: c1 = LBound(Data, 2)
Dim c2 As Long: c2 = c1 + 1
For i = LBound(Data, 1) To UBound(Data, 1)
Key = Data(i, c1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
.Item(Key) = .Item(Key) + Data(i, c2)
End If
End If
Next i
If .Count = 0 Then Exit Function
Dim Result As Variant: ReDim Result(1 To .Count, 1 To 2)
i = 0
For Each Key In .Keys
i = i + 1
Result(i, 1) = Key
Result(i, 2) = .Item(Key)
Next Key
getUniqueSum = Result
End With
End Function

Answer 2

Try This

Sub GetUniqueSum()
Dim Rng As Range
Dim numRows As Long, endRow As Long, outputRow As Long, i As Long
Dim rangeText As String
Dim acct As Variant
Dim Sum As Double, ClosingCash As Double, MarginExcess As Double
Dim FX As Double, VarMarg As Double
Dim Value As Double, Value2 As Double

'Get the last row as a string
numRows = Range("B2", Range("b2").End(xlDown)).Rows.Count
endRow = CStr(numRows + 1)
rangeText = "B2:O" & endRow

'Sort the range
Set Rng = Range("Sheet2!" & rangeText)
Rng.Sort (Rng.Columns(1))

'Initialize variables
acct = Rng.Cells(2, 1)
outputRow = 1
Sum = 0

'Calculate Sums
For i = 1 To Rng.Rows.Count
If Rng.Cells(i, 1) <> acct Then
'No longer same acct, print out results
outputRow = outputRow + 1
Worksheets("Sheet3").Cells(outputRow, 1) = acct
Worksheets("Sheet3").Cells(outputRow, 2) = Sum
acct = Rng.Cells(i, 1)
Sum = 0
End If
ClosingCash = Rng(i, 5).Value
MarginExcess = Rng(i, 9).Value
FX = Rng(i, 13).Value
VarMarg = Rng(i, 14).Value
Value = ClosingCash + VarMarg
Value2 = MarginExcess * FX
If Value > Value2 Then Value = Value2
Sum = Sum + Value
Next
'Print out last result
Worksheets("Sheet3").Cells(outputRow + 1, 1) = acct
Worksheets("Sheet3").Cells(outputRow + 1, 2) = Sum
End Sub