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

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
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
VBA problem with creating new sheets
Replies
0
Views
463
Agnarr
Agnarr
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
495
Legacy 352679
L
N
  • Question
2-step Dynamic Ranges and Charts
Replies
0
Views
336
Nick Loughton
N
john Smith72
  • Solved
count days between dates for each month by drop list
Replies
9
Views
167
Tetra201
Tetra201
B
  • Solved
VBA solution for a tally sheet, add 1 to a cell based on current date
2
Replies
10
Views
272
Burrgogi
B

Forum statistics

Threads
1,216,220
Messages
6,129,583
Members
449,520
Latest member
TBFrieds

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