vba help - to shorten working dictionary code

[Mallesh23]

Hi Team,

I am using below macro works perfectly.
Task was to Make sum of cell values .... exclude strings , #N/A, blank cells..

Is there any alternate way to check below line . just for learning purpose.
Add arr(i, 1), Array(IIf(Application.IsNumber(arr(i, 2)), arr(i, 2), 0), IIf(Application.IsNumber(arr(i, 3)), arr(i, 3), 0), Format(arr(i, 4), "Dd/mm/yyyy"))

if in future Dictionary Items may increase, IIF condition will be lengthy .

Sub test()
Dim arr As Variant
arr = Range("A1").CurrentRegion.Value2

Dim i As Long
Dim dict As New Scripting.Dictionary

With dict

        For i = LBound(arr) + 1 To UBound(arr)
            If Not .Exists(arr(i, 1)) Then
                .Add arr(i, 1), Array(IIf(Application.IsNumber(arr(i, 2)), arr(i, 2), 0), IIf(Application.IsNumber(arr(i, 3)), arr(i, 3), 0), Format(arr(i, 4), "Dd/mm/yyyy"))
            Else
                temp = .Item(arr(i, 1))
                temp(0) = temp(0) + IIf(Application.IsNumber(arr(i, 2)), arr(i, 2), 0)
                temp(1) = temp(1) + IIf(Application.IsNumber(arr(i, 3)), arr(i, 3), 0)
                .Item(arr(i, 1)) = temp
            End If
        Next i
       
        Dim c As Range
       
        For Each c In Range("K2:K4")
            If .Exists(c.Value) Then
                c.Offset(, 1).Value = .Item(c.Value)(0)
                c.Offset(, 2).Value = .Item(c.Value)(1)
                c.Offset(, 3).Value = .Item(c.Value)(2)
            End If
        Next c
    End With
End Sub

Below is a table with output.......... In future Columns may increase , how to put 10 columns into dictionary Items,

Book10
	A	B	C	D	E	F	G	H	I
1	Player	Commissioned	Salary Received	Payment Date		Player	Commissioned	Salary Received	Payment Date
2	Sachin	1000	4000	22/10/2020		Sachin	3000	11000	22/10/2020
3	Dhoni	#N/A	5000	23/10/2020		Dhoni	10000	20000	23/10/2020
4	Virat	1000	5000	24/10/2020		Virat	2000	14000	24/10/2020
5	Sachin	1000		25/10/2020
6	Dhoni	5000	7000	26/10/2020
7	Dhoni	5000	8000	26/10/2020
8	Sachin	xxx	6000	26/10/2020
9	Sachin	1000	1000	26/10/2020
10	Virat	1000	9000	26/10/2020
Sheet1

 

[Domenic]

The following macro first ensures that the values in Column 2 and Column 3 in arr are numerical values. Then it proceeds to add items to dict, etc.

Option Explicit

Sub test()

    Dim arr As Variant
    arr = Range("A1").CurrentRegion.Value2
    
    Dim i As Long
    Dim j As Long
    
    'ensure Columns 2 and 3 contain numerical values, and format the date column
    For i = LBound(arr) + 1 To UBound(arr)
        For j = 2 To 3
            If Not Application.IsNumber(arr(i, j)) Then
                arr(i, j) = 0
            End If
        Next j
        arr(i, 4) = Format(arr(i, 4), "dd/mm/yyyy")
    Next i
    
    Dim dict As New Scripting.Dictionary
    Dim tempArr As Variant
    Dim c As Range
    
    With dict
         For i = LBound(arr) + 1 To UBound(arr)
             If Not .Exists(arr(i, 1)) Then
                 .Add arr(i, 1), Application.Index(arr, i, 0) 'index returns a 1-based one dimensional array
             Else
                 tempArr = .Item(arr(i, 1))
                 For j = 2 To 3
                     tempArr(j) = tempArr(j) + arr(i, j)
                 Next j
                 .Item(arr(i, 1)) = tempArr
             End If
         Next i
        
         For Each c In Range("K2:K4")
             If .Exists(c.Value) Then
                tempArr = .Item(c.Value)
                For i = LBound(tempArr) + 1 To UBound(tempArr)
                    c.Offset(, i - 1).Value = tempArr(i)
                 Next i
             End If
         Next c
    End With
    
End Sub

Hope this helps!

 

[Mallesh23]

Hi Domenic,

Perfect ! Really nice piece of code, liked it.

Understood Code, I have two Query.

if required columns are not in sequnce Say ( My Columns are in 3,5,7) whose values needs to sum.
For j = 2 To 3 , how to modify here.

For i = LBound(arr) + 1 To UBound(arr)
        For j = 2 To 3  ......... 'how to modify if columns are in 3,5,7)
            If Not Application.IsNumber(arr(i, j)) Then
                arr(i, j) = 0
            End If
        Next j
        arr(i, 4) = Format(arr(i, 4), "dd/mm/yyyy")
 Next i

'----Query 2---
Add arr(i, 1), Application.Index(arr, i, 0)...........We are adding complete Horizontal row here

Instead of specific Columns like --Array(arr(i,2),arr(i,3),arr(i,4))........ is it right what i understood.


Columns CEH, Required Columns whose values needs to sum.
and put into Column LMNO.

Book9
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Player	Columnx	Commissioned	Column-Y	Salary Received	Column-z	Column-p	Profit	Payment Date		Player	Commissioned	Salary Received	Profit	Payment Date
2	Sachin	xxx	1000	yyyy	4000	zzz	ppp	1000	22/10/2020		Sachin	3000	11000	3000	22/10/2020
3	Dhoni	xxx	#N/A	yyyy	5000	zzz	ppp	#N/A	23/10/2020		Dhoni	10000	20000	10000	23/10/2020
4	Virat	xxx	1000	yyyy	5000	zzz	ppp	1000	24/10/2020		Virat	2000	14000	2000	24/10/2020
5	Sachin	xxx	1000	yyyy		zzz	ppp	1000	25/10/2020
6	Dhoni	xxx	5000	yyyy	7000	zzz	ppp	5000	26/10/2020
7	Dhoni	xxx	5000	yyyy	8000	zzz	ppp	5000	26/10/2020
8	Sachin	xxx	xxx	yyyy	6000	zzz	ppp	xxx	26/10/2020
9	Sachin	xxx	1000	yyyy	1000	zzz	ppp	1000	26/10/2020
10	Virat	xxx	1000	yyyy	9000	zzz	ppp	1000	26/10/2020
Sheet1

Thanks
mg

 

[Rick Rothstein]

I believe this macro (which uses a different approach than the previously posted code) will do what you asked for in your last message...

Sub Test()
  Dim R As Long, N As Long, Data As Variant
  Dim DicCommissioned As New Scripting.Dictionary, DicSalary As New Scripting.Dictionary, DicProfit As New Scripting.Dictionary, DicDate As New Scripting.Dictionary
  
  Data = Range("A1").CurrentRegion.Value
  
  For R = 2 To UBound(Data)
    DicCommissioned(Data(R, 1)) = DicCommissioned(Data(R, 1)) + IIf(IsNumeric(Data(R, 3)), Data(R, 3), 0)
    DicSalary(Data(R, 1)) = DicSalary(Data(R, 1)) + IIf(IsNumeric(Data(R, 5)), Data(R, 5), 0)
    DicProfit(Data(R, 1)) = DicProfit(Data(R, 1)) + IIf(IsNumeric(Data(R, 8)), Data(R, 8), 0)
    If Len(DicDate(Data(R, 1))) = 0 Then DicDate(Data(R, 1)) = CStr(Data(R, 9))
  Next
  
  For Each v In Array(DicCommissioned.Keys, DicCommissioned.Items, DicSalary.Items, DicProfit.Items, DicDate.Items)
    N = N + 1
    Range("J2").Offset(, N).Resize(DicDate.Count) = Application.Transpose(v)
  Next
End Sub

 

[Mallesh23]

Hi Rick and Domenic,

Thank you so much for your help, learned something new style of coding. ?


Thanks
mg

 

[Domenic]

if required columns are not in sequnce Say ( My Columns are in 3,5,7) whose values needs to sum.
For j = 2 To 3 , how to modify here.

In that case, we can first declare a variable to hold the column numbers...

    Dim sumColumns As Variant
    sumColumns = Array(3, 5, 7)

Then, instead of iterating through only Columns 2 and 3, we iterate through all columns, and then we check whether the column number matches one of the column numbers in sumColumns...

    For j = LBound(arr, 2) To UBound(arr, 2)
        If Not IsError(Application.Match(j, sumColumns, 0)) Then
            If Not Application.IsNumber(arr(i, j)) Then
                arr(i, j) = 0
            End If
        End If
    Next j

Here's the complete amended code...

Option Explicit

Sub test()

    Dim arr As Variant
    arr = Range("A1").CurrentRegion.Value2
   
    Dim sumColumns As Variant
    sumColumns = Array(3, 5, 7)
   
    Dim i As Long
    Dim j As Long
   
    For i = LBound(arr) + 1 To UBound(arr)
        For j = LBound(arr, 2) To UBound(arr, 2)
            If Not IsError(Application.Match(j, sumColumns, 0)) Then
                If Not Application.IsNumber(arr(i, j)) Then
                    arr(i, j) = 0
                End If
            End If
        Next j
        arr(i, 4) = Format(arr(i, 4), "dd/mm/yyyy")
    Next i
   
    Dim dict As New Scripting.Dictionary
    Dim tempArr As Variant
    Dim c As Range
   
    With dict
         For i = LBound(arr) + 1 To UBound(arr)
             If Not .Exists(arr(i, 1)) Then
                 .Add arr(i, 1), Application.Index(arr, i, 0) 'index returns a 1-based one dimensional array
             Else
                 tempArr = .Item(arr(i, 1))
                 For j = LBound(tempArr) To UBound(tempArr)
                    If Not IsError(Application.Match(j, sumColumns, 0)) Then
                        tempArr(j) = tempArr(j) + arr(i, j)
                    End If
                 Next j
                 .Item(arr(i, 1)) = tempArr
             End If
         Next i
       
         For Each c In Range("K2:K4")
             If .Exists(c.Value) Then
                tempArr = .Item(c.Value)
                For i = LBound(tempArr) + 1 To UBound(tempArr)
                    c.Offset(, i - 1).Value = tempArr(i)
                 Next i
             End If
         Next c
    End With
   
End Sub

 

[Domenic]

Add arr(i, 1), Application.Index(arr, i, 0)...........We are adding complete Horizontal row here

Instead of specific Columns like --Array(arr(i,2),arr(i,3),arr(i,4))........ is it right what i understood.

That's correct. Application.Index returns a one dimensional array, where the indexing starts at 1.

 

[Mallesh23]

Hi Domenic,

Really helpful learned lot of new things with your help.


I replaced below piece of code as per my according and its working now.
For i = LBound(tempArr) + 1 To UBound(tempArr)
c.Offset(, i - 1).Value = tempArr(i)
Next i

Sub test()

    Dim arr As Variant
    arr = Range("A1").CurrentRegion.Value2

    Dim sumColumns As Variant
    sumColumns = Array(3, 5, 7)

    Dim i As Long
    Dim j As Long

    For i = LBound(arr) + 1 To UBound(arr)
        For j = LBound(arr, 2) To UBound(arr, 2)
            If Not IsError(Application.Match(j, sumColumns, 0)) Then
                If Not Application.IsNumber(arr(i, j)) Then
                    arr(i, j) = 0
                End If
            End If
        Next j
        arr(i, 4) = Format(arr(i, 8), "dd/mm/yyyy")
    Next i



    Dim dict As New Scripting.Dictionary
    Dim tempArr As Variant
    Dim c As Range

    With dict
         For i = LBound(arr) + 1 To UBound(arr)
             If Not .Exists(arr(i, 1)) Then
                 .Add arr(i, 1), Application.Index(arr, i, 0) 'index returns a 1-based one dimensional array
             Else
                 tempArr = .Item(arr(i, 1))
                 For j = LBound(tempArr) To UBound(tempArr)
                    If Not IsError(Application.Match(j, sumColumns, 0)) Then
                        tempArr(j) = tempArr(j) + arr(i, j)
                    End If
                 Next j
                 .Item(arr(i, 1)) = tempArr
             End If
         Next i
    
    
    
         For Each c In Range("K2:K4")
             If .Exists(c.Value) Then
                tempArr = .Item(c.Value)
             
             
                'This loop  not giving correct output.
                For i = LBound(tempArr) + 1 To UBound(tempArr)
                    c.Offset(, i - 1).Value = tempArr(i)
                 Next i
         
            'This works.........
'                c.Offset(, 1).Value = dict.Item(c.Value)(3)
'                c.Offset(, 2).Value = dict.Item(c.Value)(5)
'                c.Offset(, 3).Value = dict.Item(c.Value)(7)
'                c.Offset(, 4).Value = dict.Item(c.Value)(4)
             
                'This also worked...........
                c.Offset(, 1).Value = tempArr(3)
                c.Offset(, 2).Value = tempArr(5)
                c.Offset(, 3).Value = tempArr(7)
                c.Offset(, 4).Value = tempArr(4)
             

             End If
         Next c
    End With


End Sub

Macro run on below Table . now its working.

Book5
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Player	Columnx	Commissioned	Column-Y	Salary Received	Column-p	Profit	Payment Date			Player	Commissioned	Salary Received	Profit	Payment Date
2	Sachin	xxx	1000	yyyy	4000	ppp	1000	22/10/2020			Sachin
3	Dhoni	xxx	#N/A	yyyy	5000	ppp	#N/A	23/10/2020			Dhoni
4	Virat	xxx	1000	yyyy	5000	ppp	1000	24/10/2020			Virat
5	Sachin	xxx	1000	yyyy		ppp	1000	25/10/2020
6	Dhoni	xxx	5000	yyyy	7000	ppp	5000	26/10/2020
7	Dhoni	xxx	5000	yyyy	8000	ppp	5000	26/10/2020
8	Sachin	xxx	xxx	yyyy	6000	ppp	xxx	26/10/2020
9	Sachin	xxx	1000	yyyy	1000	ppp	1000	26/10/2020
10	Virat	xxx	1000	yyyy	9000	ppp	1000	26/10/2020
Sheet1

Thanks
mg

 

[Domenic]

Hi Mallesh,

Or, you can do the following...

         For Each c In Range("K2:K4")
             If .Exists(c.Value) Then
                tempArr = .Item(c.Value)
                j = 1
                For i = LBound(tempArr) To UBound(tempArr)
                    If Not IsError(Application.Match(i, sumColumns, 0)) Then
                        c.Offset(, j).Value = tempArr(i)
                        j = j + 1
                    End If
                 Next i
                 c.Offset(, j).Value = tempArr(i - 1) 'last/date column
             End If
         Next c

 

[Rick Rothstein]

@Domenic and @Mallesh23,

When I run Domenic's code, I get extra information in Columns P, Q and R. Do you not get that as well? Or, perhaps, Mallesh23 is asking for that extra information and I just missed where he did that?


@Mallesh23,

It looks like I had the wrong columns referenced in the code I posted earlier. Here is my corrected macro which should produce the results you asked for (except for the extra information I noted above). Does it, in fact, produce the results you wanted? Also I would note that you do not have to put the player's names in the output Column K as the code generates and places them automatically.

Sub Test()
  Dim R As Long, N As Long, V As Variant, Data As Variant
  Dim DicCommissioned As New Scripting.Dictionary, DicSalary As New Scripting.Dictionary, DicProfit As New Scripting.Dictionary, DicDate As New Scripting.Dictionary

  Data = Range("A1").CurrentRegion.Value

  For R = 2 To UBound(Data)
    DicCommissioned(Data(R, 1)) = DicCommissioned(Data(R, 1)) + IIf(IsNumeric(Data(R, 3)), Data(R, 3), 0)
    DicSalary(Data(R, 1)) = DicSalary(Data(R, 1)) + IIf(IsNumeric(Data(R, 5)), Data(R, 5), 0)
    DicProfit(Data(R, 1)) = DicProfit(Data(R, 1)) + IIf(IsNumeric(Data(R, 7)), Data(R, 7), 0)
    If Len(DicDate(Data(R, 1))) = 0 Then DicDate(Data(R, 1)) = CStr(Data(R, 8))
  Next

  For Each V In Array(DicCommissioned.Keys, DicCommissioned.Items, DicSalary.Items, DicProfit.Items, DicDate.Items)
    N = N + 1
    Range("J2").Offset(, N).Resize(DicDate.Count) = Application.Transpose(V)
  Next
End Sub