VBA array and dictionary

R

roykana

Active Member
Joined
Mar 8, 2018
Messages
311
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

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
roykana said:
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
Click to expand...
Dear all master,

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

Thanks

Roykana
 
Upvote 0
Dear all master,

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

Thanks

Roykana
 
Upvote 0
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
 
Upvote 0
Fluff said:
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
Solution
Fluff said:
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
Click to expand...
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
 
Upvote 0
You're welcome & thanks for the feedback.

Just type vba scripting.dictionary into your prefered search engine & it will come up with multiple sites.
 
Upvote 0
Fluff said:
You're welcome & thanks for the feedback.

Just type vba scripting.dictionary into your prefered search engine & it will come up with multiple sites.
Click to expand...
vba scripting.dictionary and array like that you mean. I can learn a lot from you. I already consider you as my teacher
 
Upvote 0
Just vba scripting.dictionary
You need to do arrays separately.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Remove Duplicates with Dynamic Columns Array
Replies
0
Views
275
trough
T
R
  • Question
Having trouble transferring 2D array to Table
Replies
5
Views
260
RawlinsCross
R
A
  • Question
2D Arrays match with Column
Replies
1
Views
529
Legacy 143009
L
T
  • Solved
List values in an array?
Replies
4
Views
147
RoryA
RoryA
B
  • Solved
Slight change required to Macro
Replies
4
Views
217
Fluff
Fluff

Forum statistics

Threads
1,214,392
Messages
6,119,254
Members
448,879
Latest member
oksanana

Share this page

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
Back
Top