Convert Sumifs to vba code with loop

[lakamas]

I need to convert:

=SUMIFS($D:$D;$A:$A;"="&$G2;$B:$B;$H2;$C:$C;"="&$N$1)  

to VBA code and find a way to loop it so I can fill column K (based on the length of column G) of the example with the correct sums.

sumifexample.xlsx

[jindon]

You have prepared col G & H, Criteria 1 & 2.
Do you want to keep it remain as it is, or is it fine just the data that have month=N1?

This is to output the only data that have Month = N1
to a Sheet Module

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "N1" Then Exit Sub
    Application.EnableEvents = False
    test
    Application.EnableEvents = True
End Sub

To a standard module

Sub test()
    Dim a, i As Long, ii As Long, w, txt As String, myMonth As Long
    myMonth = [n1].Value
    a = Cells(1).CurrentRegion.Resize(, 4).Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If a(i, 3) = myMonth Then
                txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
                If Not .exists(txt) Then
                    ReDim w(1 To 3)
                    For ii = 1 To 2
                        w(ii) = a(i, ii)
                    Next
                Else
                    w = .Item(txt)
                End If
                w(3) = w(3) + a(i, 4)
                .Item(txt) = w
            End If
        Next
        a = Empty
        If .Count Then a = Application.Index(.items, 0, 0)
    End With
    [g1:h1].CurrentRegion.Offset(1).ClearContents
    [k1].CurrentRegion.Offset(1).ClearContents
    If IsArray(a) Then
        [g2:h2].Resize(UBound(a, 1)).Value = a
        [k2].Resize(UBound(a, 1)).Value = Application.Index(a, 0, 3)
    End If
End Sub

[xladept]

Hi lakamas,

Welcome to the Forum - here's another routine:

Sub lakamas(): Dim M As Long, Criteria As String, r As Long, K, Z, s As Long
            Columns("G:H").CurrentRegion.Offset(1, 0).ClearContents
            Columns("K").CurrentRegion.Offset(1, 0).ClearContents
    s = 2: M = Cells(1, "N"): With CreateObject("Scripting.Dictionary")
                For r = 2 To Range("A" & Rows.count).End(xlUp).Row
                Criteria = Trim(Range("A" & r)) & "|" & _
                Trim(Range("B" & r)) & "|" & Val(Range("C" & r))
                If .exists(Criteria) Then
                .Item(Criteria) = .Item(Criteria) + Val(Range("D" & r))
                Else: .Item(Criteria) = Val(Range("D" & r))
                End If: Next r: K = .Keys()
                        For r = LBound(K) To UBound(K): Z = Split(K(r), "|")
                        If Z(UBound(Z)) = M Then
                            Range("G" & s) = Z(0): Range("H" & s) = Z(1)
                            Range("K" & s) = .Item(K(r)): s = s + 1: End If
                        Next r: End With: End Sub

[xladept]

This is closer to what you said:

Sub lakamasII(): Dim M As Long, Criteria As String, r As Long
            Columns("K").CurrentRegion.Offset(1, 0).ClearContents
         M = Cells(1, "N"): With CreateObject("Scripting.Dictionary")
                For r = 2 To Range("A" & Rows.count).End(xlUp).Row
                Criteria = Trim(Range("A" & r)) & "|" & _
                Trim(Range("B" & r)) & "|" & Val(Range("C" & r))
                If .Exists(Criteria) Then
                .Item(Criteria) = .Item(Criteria) + Val(Range("D" & r))
                Else: .Item(Criteria) = Val(Range("D" & r))
                End If: Next r
                        For r = 2 To Range("G" & Rows.count).End(xlUp).Row
                        Criteria = Trim(Range("G" & r)) & "|" & _
                                    Trim(Range("H" & r)) & "|" & M
                        If .Exists(Criteria) Then _
                            Range("K" & r) = .Item(Criteria) Else Range("K" & r) = 0
                        Next r: End With: End Sub

[Norie]

Perhaps.

Range("K2:K" & Range("G" & Rows.Count).End(xlUp).Row).Formula = "=SUMIFS($D:$D,$A:$A,""=""&$G2,$B:$B,$H2,$C:$C,""=""&$N$1)"

[lakamas]

Guys thank you for your time,

Both of them work in their way but not exactly what I need, my problem is that I can't really understand or make changes to the code(sorry for my poor vba skills, I just started)

As for the criteria1 and 2 , this have been extracted from code1+code2 columns aiming to get as a result all the unique pairs. I have already done it so no need for changes there (always a better/efficient way to do it would be good to know)

My target is to read the already made criteria from G and H columns and do the sums. After filling the cell go to next cell of column K and do that again (based on the new Criteria).

IF(AND(HaveTime=1;HaveGoodMood=1);"please add some description on the code referring to what each part does";"I will try harder and find my way out, Thank you so much for your time")

[xladept]

Hi lakamas,

My last post with the lakamasII routine is driven by the G & H entries

You're welcome and thanks for the rep

Sub lakamasII(): Dim M As Long, Criteria As String, r As Long
            'Clear the Output Column
            Columns("K").CurrentRegion.Offset(1, 0).ClearContents
            'Get the Month wanted from N1 and initiate a dictionary
         M = Cells(1, "N"): With CreateObject("Scripting.Dictionary")
            'Well scan all the entries in Column A to Load our dictionary
                For r = 2 To Range("A" & Rows.count).End(xlUp).Row
        'We'll key our dictionary to the (concatenated with a pipe) first three column entries
                Criteria = Trim(Range("A" & r)) & "|" & _
                Trim(Range("B" & r)) & "|" & Val(Range("C" & r))
            'If we've already seen that key we'll add to its sum total
                If .Exists(Criteria) Then
                .Item(Criteria) = .Item(Criteria) + Val(Range("D" & r))
                Else: .Item(Criteria) = Val(Range("D" & r))
                End If: Next
                                'Now well scan the Column G entries
                        For r = 2 To Range("G" & Rows.count).End(xlUp).Row
            'Keying on the G & H Columns and the wanted month (concatenated with a pipe)
                        Criteria = Trim(Range("G" & r)) & "|" & _
                                    Trim(Range("H" & r)) & "|" & M
              ' If that Key has been loaded we'll put the total in Colmn K
                        'or else we'll put a zero in that row
                        If .Exists(Criteria) Then _
                            Range("K" & r) = .Item(Criteria) Else Range("K" & r) = 0
                        Next r: End With: End Sub

[jindon]

Worksheet Change event code.
1) If Cell N1 changed, call "test" procedure.

test procedure code
1) Store data in an array, variable a, to speed up the process.
2) Loop through the data and find the rows that have N1 value in Co.C
3) When found, store corresponding data to the Dictionary under unique key of Col.A & Col.B.
4) When duplicates found, add amount of Col.D to the Dictionary item.
5) OutPut the result.

[lakamas]

@xladept the code works great and I understood everything, thank you.
I just need one more thing now. When all data are in the same worksheet everything works fine but in my case I have the collums a,b,c and d in sheet1 and the rest in sheet2.
I tried to replace "A" with Sheet1!A but it didnt work , any ideas?

@jindon thank you for your time and efford.

[xladept]

I think I got them All

Sub lakamasII(): Dim M As Long, Criteria As String, r As Long
                    Dim w1 As Worksheet, w2 As Worksheet
                Set w1 = Sheets("Sheet1"): Set w2 = Sheets("Sheet2")
            w2.Columns("K").CurrentRegion.Offset(1, 0).ClearContents
         M = w2.Cells(1, "N"): With CreateObject("Scripting.Dictionary")
                For r = 2 To w1.Range("A" & Rows.count).End(xlUp).Row
                Criteria = Trim(w1.Range("A" & r)) & "|" & _
                Trim(w1.Range("B" & r)) & "|" & Val(w1.Range("C" & r))
                If .Exists(Criteria) Then
                .Item(Criteria) = .Item(Criteria) + Val(w1.Range("D" & r))
                Else: .Item(Criteria) = Val(w1.Range("D" & r))
                End If: Next r
                        For r = 2 To w2.Range("G" & Rows.count).End(xlUp).Row
                        Criteria = Trim(w2.Range("G" & r)) & "|" & _
                                    Trim(w2.Range("H" & r)) & "|" & M
                        If .Exists(Criteria) Then _
                            w2.Range("K" & r) = .Item(Criteria) Else w2.Range("K" & r) = 0
                        Next r: End With: End Sub