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

L

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

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
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
Click to expand...

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
Click to expand...


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
You must log in or register to reply here.

Similar threads

Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
813
Agnarr
Agnarr
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
912
Legacy 352679
L
S
  • Question Question
VBA code to determine InDesign Layout
Replies
6
Views
442
Akuini
Akuini
N
  • Question Question
2-step Dynamic Ranges and Charts
Replies
0
Views
1K
Nick Loughton
N
john Smith72
  • Solved
count days between dates for each month by drop list
Replies
9
Views
375
Tetra201
Tetra201

Forum statistics

Threads
1,223,908
Messages
6,175,306
Members
452,633
Latest member
DougMo

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