добавить значение в список в цикле

Question

Я бегу через столбец и сохраняю значение для каждой строки в словаре. если значение не существует, я хочу добавить значение ячейки в этой строке в массив / список. В конце я хочу сумму всех значений в массиве. Как добавить значения в массив и суммировать значения в массиве? Я надеюсь, что кто-то может помочь

Код

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

Мне не совсем ясно, чего вы добьетесь sh, но приведенный ниже код сделает большую часть этого. Пожалуйста, попробуйте.

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

Код будет oop через всех ваших участников в том, что было вашим Ws4. Это пропустит дубликаты. Уникальные участники будут добавлены в словарь с их именами (или, возможно, идентификационными номерами) в качестве ключа и процентом изменения как Item. Результатом будет один словарь со всеми уникальными именами и всеми изменениями.

Во второй половине кода этот словарь рассматривается. Изменения сортируются по положительным, отрицательным и неизменным и учитываются для каждой категории. Совокупное изменение рассчитывается и подсчитываются участники. Все это входит в окно сообщения.

Важное изменение, которое я сделал, - создание пар данных с идентификатором члена в качестве ключа и изменением в качестве связанной информации. Эти данные можно легко оценить, используя всего несколько строк кода, в зависимости от того, что вам нужно.

Answer 2

Я обновляю код следующим образом, надеясь, что он будет вам полезен:

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

Надеюсь, это решит вашу проблему