append value to list within loop - excel

Question

I am running through a column and storing the value for each row in a dictionary.
if the value does not exists i want to add a cell value on that row to an array/list. In the end i want a sum of all the values in the array.
How do i append the values to an array and sum the values in the array? I hope someone can help
Code
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

Answer 1

I'm not entirely clear about what you wish to achieve but the code below will do most of it. Please try it.
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
The code will loop through all your members in what was your Ws4. It will skip over duplicates. Unique members will be added to a dictionary with their names (or perhaps ID numbers) as Key and the percentage of change as Item. The result will be one dictionary with all unique names and all the changes.
In the second half of the code this dictionary is examined. Changes are sorted into positive, negative and unchanged and counted for each category. The aggregate change is calculated and the members counted. All of that goes into a message box.
The important change I made is to create pairs of data, with the member ID as key and the change as related information. This data can be evaluated easily, with very few lines of code, whichever way you want.

Answer 2

I update the code as following hoping it would be helpful to you:
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
Hopefully, this will solve your issue