VBA array and dictionary

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows
reference link Sumifs VBA with multiple criteria in multiple cells
I ask for help to modify the vba code so that I can use it in the file I attached with it.
I see the sumifs vba code that you created is very fast because I need to record thousands of records.
The results I want are in the "resultformula" sheet and the VBA results in sheet2.
link file : Sumifsfast.xlsm
https://drive.google.com/file/d/1KTWFyKpLLWQ3GOpfJajZpnzMPZgDBxOg/view?usp=sharing
Thanks
roykana
VBA Code:
Sub sumiffast()
    Dim dDate As Object, dCode As Object
    Dim vData As Variant, i As Long
    t = Timer
    Set dDate = CreateObject("Scripting.Dictionary")
    dDate.CompareMode = vbTextCompare
    Set dCode = CreateObject("Scripting.Dictionary")
    dCode.CompareMode = vbTextCompare
   
    'Data in Sheet1
    With Sheets("Sheet1")
        vData = .Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    For i = LBound(vData, 1) To UBound(vData, 1)
        dCode(vData(i, 2)) = vData(i, 3)
        If dDate.exists(vData(i, 1)) Then
            dDate(vData(i, 1))(vData(i, 2)) = dDate(vData(i, 1))(vData(i, 2)) + vData(i, 4)
        Else
            Set dDate(vData(i, 1)) = CreateObject("Scripting.Dictionary")
            dDate(vData(i, 1))(vData(i, 2)) = vData(i, 4)
        End If
    Next i
   
    'Results in Sheet2
    Dim vResult As Variant, j As Long
    With Sheets("Sheet2")
        .Range("A1:B1") = Array("Code", "Name")
        .Range("A2").Resize(dCode.Count, 2) = Application.Transpose(Array(dCode.keys, dCode.items))
        .Range("C1").Resize(, dDate.Count) = dDate.keys
        vResult = .Range("A1").Resize(dCode.Count + 1, dDate.Count + 2)
        For i = LBound(vResult, 1) + 1 To UBound(vResult, 1)
            For j = LBound(vResult, 2) + 2 To UBound(vResult, 2)
                vResult(i, j) = dDate(vResult(1, j))(vResult(i, 1))
            Next j
        Next i
        .Range("A1").Resize(dCode.Count + 1, dDate.Count + 2) = vResult
        .Columns("C").Resize(, dDate.Count).AutoFit
    End With
Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub
 
Last edited by a moderator:

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows
reference link Sumifs VBA with multiple criteria in multiple cells
I ask for help to modify the vba code so that I can use it in the file I attached with it.
I see the sumifs vba code that you created is very fast because I need to record thousands of records.
The results I want are in the "resultformula" sheet and the VBA results in sheet2.
link file : Sumifsfast.xlsm
https://drive.google.com/file/d/1KTWFyKpLLWQ3GOpfJajZpnzMPZgDBxOg/view?usp=sharing
Thanks
roykana
VBA Code:
Sub sumiffast()
    Dim dDate As Object, dCode As Object
    Dim vData As Variant, i As Long
    t = Timer
    Set dDate = CreateObject("Scripting.Dictionary")
    dDate.CompareMode = vbTextCompare
    Set dCode = CreateObject("Scripting.Dictionary")
    dCode.CompareMode = vbTextCompare
  
    'Data in Sheet1
    With Sheets("Sheet1")
        vData = .Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    For i = LBound(vData, 1) To UBound(vData, 1)
        dCode(vData(i, 2)) = vData(i, 3)
        If dDate.exists(vData(i, 1)) Then
            dDate(vData(i, 1))(vData(i, 2)) = dDate(vData(i, 1))(vData(i, 2)) + vData(i, 4)
        Else
            Set dDate(vData(i, 1)) = CreateObject("Scripting.Dictionary")
            dDate(vData(i, 1))(vData(i, 2)) = vData(i, 4)
        End If
    Next i
  
    'Results in Sheet2
    Dim vResult As Variant, j As Long
    With Sheets("Sheet2")
        .Range("A1:B1") = Array("Code", "Name")
        .Range("A2").Resize(dCode.Count, 2) = Application.Transpose(Array(dCode.keys, dCode.items))
        .Range("C1").Resize(, dDate.Count) = dDate.keys
        vResult = .Range("A1").Resize(dCode.Count + 1, dDate.Count + 2)
        For i = LBound(vResult, 1) + 1 To UBound(vResult, 1)
            For j = LBound(vResult, 2) + 2 To UBound(vResult, 2)
                vResult(i, j) = dDate(vResult(1, j))(vResult(i, 1))
            Next j
        Next i
        .Range("A1").Resize(dCode.Count + 1, dDate.Count + 2) = vResult
        .Columns("C").Resize(, dDate.Count).AutoFit
    End With
Debug.Print "It's done in: " & Timer - t & " seconds"
End Sub
Dear all master,

can anyone help me to modify this vba code according to the file I attached

Thanks

Roykana
 

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows
Dear all master,

can anyone help me to modify this vba code according to the file I attached

Thanks

Roykana
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,869
Office Version
  1. 365
Platform
  1. Windows
In future you would be better of just explaining what you are after, rather than posting some random code that is nothing like what you need.

How about
VBA Code:
Sub roykana()
   Dim Ary As Variant, Tmp As Variant
   Dim r As Long
   
   Ary = Sheets("Sheet1").ListObjects("Sheet1").DataBodyRange.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(Ary(r, 3), 0)
         Else
            Tmp = .Item(Ary(r, 6))(0) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(Tmp, 0)
         End If
      Next r
      Ary = Sheets("Sheet3").ListObjects("sheet3").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, Ary(r, 3))
         Else
            Tmp = .Item(Ary(r, 6))(1) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), Tmp)
         End If
      Next r
      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 2).Value = Application.Index(.items, 0)
   End With
End Sub
 

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

In future you would be better of just explaining what you are after, rather than posting some random code that is nothing like what you need.

How about
VBA Code:
Sub roykana()
   Dim Ary As Variant, Tmp As Variant
   Dim r As Long
  
   Ary = Sheets("Sheet1").ListObjects("Sheet1").DataBodyRange.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(Ary(r, 3), 0)
         Else
            Tmp = .Item(Ary(r, 6))(0) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(Tmp, 0)
         End If
      Next r
      Ary = Sheets("Sheet3").ListObjects("sheet3").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, Ary(r, 3))
         Else
            Tmp = .Item(Ary(r, 6))(1) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), Tmp)
         End If
      Next r
      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 2).Value = Application.Index(.items, 0)
   End With
End Sub
Dear Mr Fluff,


Thank you for your reply. Runs perfectly and very fast.
f I add data with the same data structure, that is, the example in sheet4 and the result in sheet2 in D2. how about vba code?
Thanks
Roykana
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,869
Office Version
  1. 365
Platform
  1. Windows
If you want it to work for 3 sheets why didn't you say so?
Try
VBA Code:
Sub roykana()
   Dim Ary As Variant, Tmp As Variant
   Dim r As Long
   
   Ary = Sheets("Sheet1").ListObjects("Sheet1").DataBodyRange.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(Ary(r, 3), 0, 0)
         Else
            Tmp = .Item(Ary(r, 6))(0) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(Tmp, 0, 0)
         End If
      Next r
      Ary = Sheets("Sheet3").ListObjects("sheet3").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, Ary(r, 3), 0)
         Else
            Tmp = .Item(Ary(r, 6))(1) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), Tmp, 0)
         End If
      Next r
      Ary = Sheets("Sheet4").ListObjects("sheet4").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, 0, Ary(r, 3))
         Else
            Tmp = .Item(Ary(r, 6))(2) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), .Item(Ary(r, 6))(1), Tmp)
         End If
      Next r

      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 3).Value = Application.Index(.items, 0)
   End With
End Sub
 
Solution

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

If you want it to work for 3 sheets why didn't you say so?
Try
VBA Code:
Sub roykana()
   Dim Ary As Variant, Tmp As Variant
   Dim r As Long
  
   Ary = Sheets("Sheet1").ListObjects("Sheet1").DataBodyRange.Value2
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(Ary(r, 3), 0, 0)
         Else
            Tmp = .Item(Ary(r, 6))(0) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(Tmp, 0, 0)
         End If
      Next r
      Ary = Sheets("Sheet3").ListObjects("sheet3").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, Ary(r, 3), 0)
         Else
            Tmp = .Item(Ary(r, 6))(1) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), Tmp, 0)
         End If
      Next r
      Ary = Sheets("Sheet4").ListObjects("sheet4").DataBodyRange.Value2
      For r = 1 To UBound(Ary)
         If Not .Exists(Ary(r, 6)) Then
            .Add Ary(r, 6), Array(0, 0, Ary(r, 3))
         Else
            Tmp = .Item(Ary(r, 6))(2) + Ary(r, 3)
            .Item(Ary(r, 6)) = Array(.Item(Ary(r, 6))(0), .Item(Ary(r, 6))(1), Tmp)
         End If
      Next r

      Sheets("Sheet2").Range("A2").Resize(.Count).Value = Application.Transpose(.Keys)
      Sheets("Sheet2").Range("B2").Resize(.Count, 3).Value = Application.Index(.items, 0)
   End With
End Sub
Dear Mr. Fluff,
Thank you very much for your reply. It runs perfectly and the speed is very fast.
You are a vba expert or master. May I request a link so I can delve into vba arrays and dictionary.
Thanks
Roykana
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,869
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.

Just type vba scripting.dictionary into your prefered search engine & it will come up with multiple sites.
 

roykana

Board Regular
Joined
Mar 8, 2018
Messages
120
Office Version
  1. 2010
Platform
  1. Windows
You're welcome & thanks for the feedback.

Just type vba scripting.dictionary into your prefered search engine & it will come up with multiple sites.
vba scripting.dictionary and array like that you mean. I can learn a lot from you. I already consider you as my teacher
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
56,869
Office Version
  1. 365
Platform
  1. Windows
Just vba scripting.dictionary
You need to do arrays separately.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,154
Messages
5,640,445
Members
417,143
Latest member
boukadidanizar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top