VBA How to split date range and volume into months?

1

15266

New Member
Joined
Feb 10, 2016
Messages
10
Hi!

I'm rather new to the forum and have been searching all over the place for some VBA code proposal I could apply to my problem.
Sadly I'm very inexperienced still (began learning on my own some weeks ago) and therefore haven't gotten a lot further.

The big list of data I work with in sheet 1 is as follows:
Sales contracts in A:A
Product in B:B
The number of products booked per Sales contract in cell A in C:C
A valid start date in D:D
A valid end date in E:E
The number of months validity in F:F (which I calculate myself based on C and D's input by means of formula)

What I'm looking for in the VBA code:
to allow me to paste data in sheet1 according to the structure above and accordingly will create in sheet2 a table per contract and product with
- a column for each month of the date range per contract, e.g. C1= 01.07.2016 and D1= 30.09.2016 so July 2016, August 2016 and September 2016
- divide the number of products on that contract equally over each month
- months outside of the range of course should not show any value
- needs to allow year changeovers
- preferably ran after a click on a button

We have made a file with excel formula but it's not pretty (plus sensitive info), so hence my post here
smile.gif

I've made a layout example in excel (example below).

Any help is much appreciated, of course I will continue to study my file improvements but a start would be great!

Sheet 1
[TABLE="width: 500"]
<tbody>[TR]
[TD]Contract[/TD]
[TD]Product[/TD]
[TD]Nr products[/TD]
[TD]Valid start[/TD]
[TD]Valid end[/TD]
[TD]Nr of months[/TD]
[/TR]
[TR]
[TD]201601[/TD]
[TD]x[/TD]
[TD]3[/TD]
[TD]01.07.2016[/TD]
[TD]30.09.2016[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]201602[/TD]
[TD]y[/TD]
[TD]16[/TD]
[TD]01.04.2015[/TD]
[TD]31.08.2016[/TD]
[TD]17[/TD]
[/TR]
</tbody>[/TABLE]

Sheet 2
[TABLE="width: 500"]
<tbody>[TR]
[TD]Contract[/TD]
[TD]Product[/TD]
[TD][/TD]
[TD]Apr 15[/TD]
[TD]May 15[/TD]
[TD]Jun 15[/TD]
[TD]Jul 15[/TD]
[TD]Aug 15[/TD]
[TD]Sep 15[/TD]
[TD]Okt 15[/TD]
[TD]Nov 15[/TD]
[TD]Dec 15[/TD]
[TD]Jan 16[/TD]
[TD]Feb 16[/TD]
[TD]Mar 16[/TD]
[TD]Apr 16[/TD]
[TD]May 16[/TD]
[TD]Jun 16[/TD]
[TD]Jul 16[/TD]
[TD]Aug 16[/TD]
[TD]Sep 16[/TD]
[/TR]
[TR]
[TD]201601[/TD]
[TD]x[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]1[/TD]
[TD]1[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]201602[/TD]
[TD]y[/TD]
[TD][/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD]0.941[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Hi, On the assumption that your dates are actual Dates and not Strings, then try this for Data sheet1 and results on sheet 2.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG19Jul02
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, oMax [COLOR="Navy"]As[/COLOR] Date, oMin [COLOR="Navy"]As[/COLOR] Date, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]With[/COLOR] Sheets("Sheet3")
    [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] n = 0 To -1 [COLOR="Navy"]Step[/COLOR] -1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] n = 0 [COLOR="Navy"]Then[/COLOR]
            oMax = Application.Max(oMax, Dn.Offset(, n).Value)
            oMin = oMax
        [COLOR="Navy"]Else[/COLOR]
            oMin = Application.Min(oMin, Dn.Offset(, n))
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]With[/COLOR] Sheets("Sheet4")
     .Range("A1:c1").Value = Array("Contract", "Product", oMin)
    .Range("C1").AutoFill Destination:=.Range("c1").Resize(, DateDiff("m", oMin, oMax) + 1), Type:=xlFillMonths
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
    .Range("C1").Resize(, Lst - 2).NumberFormat = "mmm-yy"
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] .Range("C1").Resize(, Lst - 2)
            [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = Dn
        [COLOR="Navy"]Next[/COLOR]
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Offset(, -1)
            [COLOR="Navy"]If[/COLOR] Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                .Cells(Dn.Row, Dic(Dn.Value).Column).Resize(, Dn.Offset(, 2)).Value = Format(Dn.Offset(, -1).Value / Dn.Offset(, 2).Value, "0.000")
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG said:
Hi, On the assumption that your dates are actual Dates and not Strings, then try this for Data sheet1 and results on sheet 2.
Code: 
[COLOR=Navy]Sub[/COLOR] MG19Jul02
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, oMax [COLOR=Navy]As[/COLOR] Date, oMin [COLOR=Navy]As[/COLOR] Date, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Lst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Dic [COLOR=Navy]As[/COLOR] Object
[COLOR=Navy]With[/COLOR] Sheets("Sheet3")
    [COLOR=Navy]Set[/COLOR] Rng = .Range(.Range("E2"), .Range("E" & Rows.Count).End(xlUp))
[COLOR=Navy]End[/COLOR] With
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR=Navy]For[/COLOR] n = 0 To -1 [COLOR=Navy]Step[/COLOR] -1
    [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
        [COLOR=Navy]If[/COLOR] n = 0 [COLOR=Navy]Then[/COLOR]
            oMax = Application.Max(oMax, Dn.Offset(, n).Value)
            oMin = oMax
        [COLOR=Navy]Else[/COLOR]
            oMin = Application.Min(oMin, Dn.Offset(, n))
        [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]With[/COLOR] Sheets("Sheet4")
     .Range("A1:c1").Value = Array("Contract", "Product", oMin)
    .Range("C1").AutoFill Destination:=.Range("c1").Resize(, DateDiff("m", oMin, oMax) + 1), Type:=xlFillMonths
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
    .Range("C1").Resize(, Lst - 2).NumberFormat = "mmm-yy"
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] .Range("C1").Resize(, Lst - 2)
            [COLOR=Navy]Set[/COLOR] Dic(Dn.Value) = Dn
        [COLOR=Navy]Next[/COLOR]
        [COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng.Offset(, -1)
            [COLOR=Navy]If[/COLOR] Dic.exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
                .Cells(Dn.Row, Dic(Dn.Value).Column).Resize(, Dn.Offset(, 2)).Value = Format(Dn.Offset(, -1).Value / Dn.Offset(, 2).Value, "0.000")
            [COLOR=Navy]End[/COLOR] If
        [COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick
Click to expand...

Thanks a bunch Mick! That works, the only thing that doesn't get picked up are the contract and product values in cells A2:B3 of sheet2. Would you happen to have a suggestion for that?
 
Upvote 0
Sorry slight oversight !!!
Add the lines in "Bold"
Code: 
With Sheets("Sheet4")
     .Range("A1:c1").Value = Array("Contract", "Product", oMin)
    .Range("C1").AutoFill Destination:=.Range("c1").Resize(, DateDiff("m", oMin, oMax) + 1), Type:=xlFillMonths
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
    .Range("C1").Resize(, Lst - 2).NumberFormat = "mmm-yy"
        For Each Dn In .Range("C1").Resize(, Lst - 2)
            Set Dic(Dn.Value) = Dn
        Next
        For Each Dn In Rng.Offset(, -1)
            If Dic.exists(Dn.Value) Then
               [COLOR="#FF0000"][/COLOR][B] .Cells(Dn.Row, 1).Value = Dn.Offset(, -3).Value
                .Cells(Dn.Row, 2).Value = Dn.Offset(, -2).Value[/B]                .Cells(Dn.Row, Dic(Dn.Value).Column).Resize(, Dn.Offset(, 2)).Value = Format(Dn.Offset(, -1).Value / Dn.Offset(, 2).Value, "0.000")
            End If
        Next Dn
End With
 
Last edited:
Upvote 0
MickG said:
Sorry slight oversight !!!
Add the lines in "Bold"
Code: 
With Sheets("Sheet4")
     .Range("A1:c1").Value = Array("Contract", "Product", oMin)
    .Range("C1").AutoFill Destination:=.Range("c1").Resize(, DateDiff("m", oMin, oMax) + 1), Type:=xlFillMonths
    Lst = .Cells("1", Columns.Count).End(xlToLeft).Column
    .Range("C1").Resize(, Lst - 2).NumberFormat = "mmm-yy"
        For Each Dn In .Range("C1").Resize(, Lst - 2)
            Set Dic(Dn.Value) = Dn
        Next
        For Each Dn In Rng.Offset(, -1)
            If Dic.exists(Dn.Value) Then
               [B] .Cells(Dn.Row, 1).Value = Dn.Offset(, -3).Value
                .Cells(Dn.Row, 2).Value = Dn.Offset(, -2).Value[/B]                .Cells(Dn.Row, Dic(Dn.Value).Column).Resize(, Dn.Offset(, 2)).Value = Format(Dn.Offset(, -1).Value / Dn.Offset(, 2).Value, "0.000")
            End If
        Next Dn
End With
Click to expand...
My god, FANTASTIC!! Thank you so much :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Evaluate date range and return the corresponding month and year
Replies
1
Views
171
Scott Huish
Scott Huish
W
  • Solved
Validate month based on contract dates & Calculate number of weeks in that month to calculate hours booked per month
2
Replies
16
Views
2K
phiero21
P
B
  • Question Question
calculate monthly value
Replies
0
Views
268
BrutalLogiC
B
A
  • Question Question
Assign Month number 1 to n based on sequential week range
Replies
6
Views
472
amolvijay
A
J
  • Question Question
auto filling cells based on preset format
Replies
1
Views
31
HighAndWilder
H

Forum statistics

Threads
1,224,590
Messages
6,179,762
Members
452,940
Latest member
rootytrip

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