VBA code to look through dates in a column and create statistic for each month in a chosen year?

lars_mn

New Member
Joined
Oct 5, 2015
Messages
24
I have a spreadsheet where column “H” has dates in format dd.mm.yyyy (examples 31.12.2017). The number of rows and the dates in column “H” varies each time I run the code.
I need a code that will look through all the dates in column “H” and summarize them for each month of a chosen year and generate a statistic in a new sheet. The statistic I want to generate will look something like this. Maybe the code can ask for the year via an input box when the code is started.
Period
Quantity
Percentage
Jan-17
11
1%
Feb-17
26
2%
Mar-17
30
2%
Apr-17
11
1%
May-17
42
3%
Jun-17
32
2%
Jul-17
165
13%
Aug-17
178
14%
Sep-17
0
0%
Oct-17
0
0%
Nov-17
0
0%
Dec-17
0
0%
Total
1300
38%

<tbody>
</tbody>


  1. Period; is each month of the year chosen.
  2. Quantity; is the amount of dates in each chosen month of chosen year.
  3. Total quantity; is the total number of dates in the entire table, not only the chosen year.
  4. Percentage is quantity of each month compared to total quantity in percent rounded up to a whole number.
Does anyone have a solution for this in VBA?
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Try this for results for selected (Inbox) year in columns "K to M", based on Dates in column "H".
Code:
[COLOR="Navy"]Sub[/COLOR] MG28Aug12
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic             [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] k               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] St              [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oSum            [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 [COLOR="Navy"]Dim[/COLOR] TotSum         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("H2", Range("H" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dic.exists(Year(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
             [COLOR="Navy"]Set[/COLOR] Dic(Year(Dn.Value)) = CreateObject("Scripting.Dictionary")
        [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]If[/COLOR] Not Dic(Year(Dn.Value)).exists(Month(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
            Dic(Year(Dn.Value)).Add (Month(Dn.Value)), 1
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(Year(Dn.Value)).Item(Month(Dn.Value))
            Q = Q + 1
            Dic(Year(Dn.Value)).Item(Month(Dn.Value)) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
  
  
[COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
St = Application.InputBox(prompt:="Enter Year from List :-" & _
vbLf & Join(Dic.Keys, ", "), Title:="Insert Year", Type:=1)
    [COLOR="Navy"]If[/COLOR] St = False Or Len(St) <> 4 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
        [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] GoTo 0
ReDim Ray(1 To 14, 1 To 3)
 Ray(1, 1) = "Period": Ray(1, 2) = "Quantity": Ray(1, 3) = "Percentage"
  
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
    TotSum = TotSum + Application.Sum(Dic(k).items())
    [COLOR="Navy"]If[/COLOR] k = St [COLOR="Navy"]Then[/COLOR]
        oSum = Application.Sum(Dic(k).items())
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            Ray(n + 1, 1) = Format(DateSerial(k, n, 1), "mmm_yy")
            Ray(n + 1, 2) = Dic(k).Item(n)
            Ray(n + 1, 3) = Format(Dic(k).Item(n) / oSum, "0.0%")
        [COLOR="Navy"]Next[/COLOR] n
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] k
Ray(14, 1) = "Total": Ray(14, 2) = TotSum: Ray(14, 3) = Format(oSum / TotSum, "0%")
Range("K1").Resize(14, 3).Value = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick

Perfect except for one small thing. The percentages in your code are "wrong". The percentage for january in my example above is 11 (the quantity in jan-17) divided with 1300 (the total quantity of all years, not only 2017). In your code you divide with total quantity for 2017.
Do you have an idea for this?
 
Upvote 0
Try changing the "oSum" variable to the "TotSum" variable, as below:-
Code:
For n = 1 To 12
            Ray(n + 1, 1) = Format(DateSerial(K, n, 1), "mmm_yy")
            Ray(n + 1, 2) = Dic(K).Item(n)
            Ray(n + 1, 3) = Format(Dic(K).Item(n) / [B][COLOR=#FF0000]TotSum[/COLOR][/B], "0%")
        Next n
 
Upvote 0
That does not work, I already tried it.

If i put a msgbox like below I get 3 different TotSym values (first is for the chosen year, second I dont know and the third is for all years):
For Each k In Dic.Keys
TotSum = TotSum + Application.Sum(Dic(k).items())
MsgBox TotSum
If k = St Then
oSum = Application.Sum(Dic(k).items())
For n = 1 To 12
Ray(n + 1, 1) = Format(DateSerial(k, n, 1), "mmm_yy")
Ray(n + 1, 2) = Dic(k).Item(n)
Ray(n + 1, 3) = Format(Dic(k).Item(n) / TotSum, "0.0%")
Next n

If I put msgbox at the end like below I get the quantity for all years
MsgBox TotSum
Ray(14, 1) = "Total": Ray(14, 2) = TotSum: Ray(14, 3) = Format(oSum / TotSum, "0%")
Range("K1").Resize(14, 3).Value = Ray


The TotSum is wrong when it is being used to calculate the percentages. I hope you know what I mean :)
 
Last edited:
Upvote 0
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG29Aug54
[COLOR="Navy"]Dim[/COLOR] Dn              [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] n               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng             [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic             [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] K               [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c               [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] st              [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] oSum            [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 [COLOR="Navy"]Dim[/COLOR] TotSum         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("H2", Range("H" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
   [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Year(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
             [COLOR="Navy"]Set[/COLOR] Dic(Year(Dn.Value)) = CreateObject("Scripting.Dictionary")
        [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]If[/COLOR] Not Dic(Year(Dn.Value)).Exists(Month(Dn.Value)) [COLOR="Navy"]Then[/COLOR]
            Dic(Year(Dn.Value)).Add (Month(Dn.Value)), 1
        [COLOR="Navy"]Else[/COLOR]
            Q = Dic(Year(Dn.Value)).Item(Month(Dn.Value))
            Q = Q + 1
            Dic(Year(Dn.Value)).Item(Month(Dn.Value)) = Q
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
  
  
[COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
st = Application.InputBox(prompt:="Enter Year from List :-" & _
vbLf & Join(Dic.keys, ", "), Title:="Insert Year", Type:=1)
    [COLOR="Navy"]If[/COLOR] st = False Or Len(st) <> 4 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
        [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] GoTo 0
ReDim Ray(1 To 14, 1 To 3)
 Ray(1, 1) = "Period": Ray(1, 2) = "Quantity": Ray(1, 3) = "Percentage"
  
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    TotSum = TotSum + Application.Sum(Dic(K).items())
    [COLOR="Navy"]If[/COLOR] K = st [COLOR="Navy"]Then[/COLOR]
        oSum = Application.Sum(Dic(K).items())
        [COLOR="Navy"]For[/COLOR] n = 1 To 12
            Ray(n + 1, 1) = Format(DateSerial(K, n, 1), "mmm_yy")
            Ray(n + 1, 2) = Dic(K).Item(n)
            Ray(n + 1, 3) = Dic(K).Item(n)
        [COLOR="Navy"]Next[/COLOR] n
   [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]For[/COLOR] n = 1 To 12
    Ray(n + 1, 3) = Format(Ray(n + 1, 3) / TotSum, "0%")
[COLOR="Navy"]Next[/COLOR] n
Ray(14, 1) = "Total": Ray(14, 2) = TotSum: Ray(14, 3) = Format(oSum / TotSum, "0%")
Range("K1").Resize(14, 3).Value = Ray
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Works perfectly, thank you so much :)
One last question. Is there an easy fix to build the table on a new sheet named "Statistics"?
 
Upvote 0
You're welcome
Ref Question:- Just change the last line to:-
Code:
[COLOR=#FF0000]Sheets("Statistics").Range("A1").[/COLOR]Resize(14, 3).Value = Ray
 
Upvote 0

Forum statistics

Threads
1,224,827
Messages
6,181,200
Members
453,022
Latest member
RobertV1609

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