我正在遍历一列，并将每一行的值存储在字典中。 如果该值不存在，我想将该行的单元格值添加到数组/列表中。最后，我想要数组中所有值的总和。 如何将值附加到数组并求和数组中的值？希望有人能帮忙
代码
Const NETSCONT_SHT3 = "D"
Const NETSCONT_SHT4 = "I"
Const NETSEXP_SHT4 = "H"
Const MEMBER_SHT4 = "G"
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim iRow As Long, iLastRow, iTargetRow As Long, iCopyRow As Long, NbCont_SHT3 As Long, AmCont_SHT3 As Double
Dim NbCont_SHT4 As Long, AmCont_SHT4 As Double, NbResults As Integer, AmResult As Double, pct_change As Double
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
Dim Rng As Range
Dim r As Long
Dim d As Long, dE As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionSplitReport")
Set ws4 = wb.Sheets("ContributionExceptionReport")
Dim dict As Object, dictEXP As Object, dictRESULTP As Object, dictRESULTN As Object, dictMEMBER As Object, sKey As Double, ar As Variant
Dim sEXP As Double, sRESP As Double, sRESN As Double, sMEMBER As Integer, arEXP As Variant, arRESP As Variant, arRESN As Variant, arMEMBER As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set dictEXP = CreateObject("Scripting.Dictionary")
Set dictRESULTP = CreateObject("Scripting.Dictionary")
Set dictRESULTN = CreateObject("Scripting.Dictionary")
Set dictMEMBER = CreateObject("Scripting.Dictionary")
iLastRow = ws4.Cells(Rows.count, MEMBER_SHT4).End(xlUp).Row
For iRow = 18 To iLastRow
sMEMBER = ws4.Cells(iRow, MEMBER_SHT4) ' column "G"
sKey = ws4.Cells(iRow, NETSCONT_SHT4) ' column "I"
sEXP = ws4.Cells(iRow, NETSEXP_SHT4) ' column "H"
If dictMEMBER.exists(sMEMBER) Then
dictMEMBER(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow
Else
dictMEMBER(sMEMBER) = iRow
If sKey <> "0" Then
pct_change = (sKey - sEXP) / sKey
If pct_change > 0 Then
dictRESULTP.Add d, pct_change: d = d + 1
ElseIf pct_change < 0 Then
dictRESULTN.Add dE, pct_change: dE = dE + 1
End If
End If
'If dictMEMBER(sMEMBER) does not exist I want to append the cell value (irow, i) into an array.
'In the end i want to sum the value of the array
End If
next
答案 0 :(得分：1)
对于您希望实现的目标，我还不太清楚，但是下面的代码可以完成大部分工作。请尝试。
Sub Benchmark()
' This proc needs a reference to 'Miscrosoft Scripting Runtime'
' If you use late binding VBA will do without the reference but you
' won't have the benefit of Intellisense drop-downs while programming.
' Checkmark: Tools > References > Microsoft Scripting Runtime'
Const ConExMember = "G"
Const ConExExp = "H"
Const ConExAct = "I"
Dim Wb As Workbook
Dim WsConEx As Worksheet
Dim Dict As Scripting.Dictionary
Dim Member As String
Dim Expected As Double, Actual As Double
Dim ChangePct As Double
Dim Rl As Long ' last row
Dim R As Long ' rows loop counter
Dim Tmp As Variant
Dim Msg As String, Count(2) As Integer
Set Wb = ThisWorkbook
Set WsConEx = Wb.Sheets("ContributionExceptionReport")
Set Dict = CreateObject("Scripting.Dictionary")
' pct change in expected and actual cont
With WsConEx
Rl = .Cells(.Rows.Count, ConExMember).End(xlUp).Row
For R = 18 To Rl
Member = .Cells(R, ConExMember).Value
Actual = Val(.Cells(R, ConExAct).Value)
Expected = Val(.Cells(R, ConExExp).Value)
On Error Resume Next ' if Actual = 0
ChangePct = (Actual - Expected) / Actual
If Err.Number Then ChangePct = 0
On Error GoTo 0
If Not Dict.Exists(Member) Then
Dict.Add Member, ChangePct
End If
Next R
End With
ChangePct = 0
For Each Tmp In Dict.Keys
ChangePct = ChangePct + Dict(Tmp)
R = Sgn(Dict(Tmp)) + 1
Count(R) = Count(R) + 1
Next Tmp
Msg = "Members: " & Dict.Count & vbCr & _
"Increases: " & Count(2) & vbCr & _
"Decreases: " & Count(1) & vbCr & _
"Unchanged: " & Count(0) & vbCr & _
"Change % : " & Round(ChangePct * 100, 2) & "%"
MsgBox Msg, vbInformation, "Summary"
End Sub
该代码将遍历您的Ws4中的所有成员。它将跳过重复项。唯一成员将被添加到词典中，其名称（或ID号）为Key，更改百分比为Item。结果将是一本包含所有唯一名称和所有更改的字典。
在代码的后半部分检查此字典。更改分为积极，消极和不变，并针对每个类别进行计数。计算总变化并计算成员数。所有这些都进入一个消息框。
我所做的重要更改是创建数据对，以成员ID为键，而更改为相关信息。只需使用几行代码，即可轻松评估这些数据，无论您使用哪种方式。
答案 1 :(得分：0)
我更新代码如下，希望对您有所帮助：
Sub AddAndSumMissingDictionary()
'Constants
Const NETSCONT_SHT3 = "D"
Const NETSEXP_SHT4 = "H"
Const NETSCONT_SHT4 = "I"
Const MEMBER_SHT4 = "G"
'ArrayColumns
Const cTotalExpected = 0
Const cTotalNets = 1
Const cTotalNetSplitAVC = 2
'Workbooks & Worksheets
Dim wb As Workbook, wbNew As Workbook
Dim ws1 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim WkSht_Src As Worksheet
Dim WkBk_Dest As Workbook
Dim WkSht_Dest As Worksheet
'Array you Requested
Dim ArrMissingDictionary() As Double
Dim lMissingDictCount As Long
'Iteration Rows & Ranges
Dim iRow As Long, iLastRow As Long, iTargetRow As Long, iCopyRow As Long, NbCont_SHT3 As Long, AmCont_SHT3 As Double
Dim NbCont_SHT4 As Long, AmCont_SHT4 As Double, NbResults As Integer, AmResult As Double, pct_change As Double
Dim msg As String, i As Integer, j As Integer
Dim count As Long, countWB As Integer
Dim Rng As Range
Dim r As Long
Dim d As Long, dE As Long
'Initializing Variables
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("BrokerSelect")
Set ws3 = wb.Sheets("ContributionSplitReport")
Set ws4 = wb.Sheets("ContributionExceptionReport")
Dim dict As Object, dictEXP As Object, dictRESULTP As Object, dictRESULTN As Object, dictMEMBER As Object, sKey As Double, ar As Variant
Dim sEXP As Double, sRESP As Double, sRESN As Double, sMEMBER As Integer, arEXP As Variant, arRESP As Variant, arRESN As Variant, arMEMBER As Variant
'Initializing Dictionaries
Set dict = CreateObject("Scripting.Dictionary")
Set dictEXP = CreateObject("Scripting.Dictionary")
Set dictRESULTP = CreateObject("Scripting.Dictionary")
Set dictRESULTN = CreateObject("Scripting.Dictionary")
Set dictMEMBER = CreateObject("Scripting.Dictionary")
'Set Missing lMissingDictCount to 0
lMissingDictCount = 0
'Get the Last Row
iLastRow = ws4.Cells(Rows.count, MEMBER_SHT4).End(xlUp).Row
'Iteration Process
For iRow = 18 To iLastRow
sMEMBER = ws4.Cells(iRow, MEMBER_SHT4) ' column "G"
sKey = ws4.Cells(iRow, NETSCONT_SHT4) ' column "I"
sEXP = ws4.Cells(iRow, NETSEXP_SHT4) ' column "H"
'Checking Existance of Dictionary Entry
If dictMEMBER.exists(sMEMBER) Then
'I think this should be like this
dictMEMBER.Key(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow 'dictMEMBER(sMEMBER) = dictMEMBER(sMEMBER) & ";" & iRow
Else
dictMEMBER.Key(sMEMBER) = iRow 'dictMEMBER(sMEMBER) = iRow
If sKey <> "0" Then
pct_change = (sKey - sEXP) / sKey
If pct_change > 0 Then
dictRESULTP.Add d, pct_change: d = d + 1
ElseIf pct_change < 0 Then
dictRESULTN.Add dE, pct_change: dE = dE + 1
End If
End If
'Increment lMissingDictCount
lMissingDictCount = lMissingDictCount + 1 'UBound(ArrMissingDictionary, 1) + 1
'Adding the Array:
ReDim Preserve ArrMissingDictionary(2, lMissingDictCount) 'Increasing the Array Row while keeping its content
ArrMissingDictionary(cTotalExpected, lMissingDictCount) = ws4.Cells(iRow, NETSEXP_SHT4)
ArrMissingDictionary(cTotalNets, lMissingDictCount) = ws4.Cells(iRow, NETSCONT_SHT4)
ArrMissingDictionary(cTotalNetSplitAVC, lMissingDictCount) = ws4.Cells(iRow, MEMBER_SHT4)
'If dictMEMBER(sMEMBER) does not exist I want to append the cell value (irow, i) into an array.
End If
Next iRow
'In the end i want to sum the value of the array
'I'm reusing the iRow again
Dim dTotalExpected As Double, dTotalNets As Double, dTotalNetSplitAVC As Double
For iRow = LBound(ArrMissingDictionary, 1) To UBound(ArrMissingDictionary, 1)
dTotalExpected = dTotalExpected + ArrMissingDictionary(cTotalExpected, iRow) 'Sum Missing on Col "H"
dTotalNets = dTotalNets + ArrMissingDictionary(cTotalNets, iRow) 'Sum Missing on Col "I"
dTotalNetSplitAVC = dTotalNetSplitAVC + ArrMissingDictionary(cTotalNetSplitAVC, iRow) 'Sum Missing on Col "G"
Next iRow
'You can affect the dTotalExpected, dTotalNets and dTotalNetSplitAVC for your purpose
End Sub
希望这能解决您的问题