VBA to split start date and end date into days per month in separate rows

M

motherindia

Board Regular
Joined
Oct 15, 2015
Messages
218
Hello Sir
I have data on sheet1 as follows;


Cust IDType Begin DateEnd DateNo of days
1Luxury23-Mar-1723-Mar-171
1Luxury28-Mar-1728-Mar-171
1Luxury29-Mar-1729-Mar-171
1Luxury30-Mar-1730-Mar-170.5
1Luxury31-Mar-1731-Mar-170.5
1Luxury08-Apr-1708-Apr-170.5
1Luxury08-Apr-1708-Apr-170.5
1Luxury 10-Apr-17 12-Apr-173

<tbody>
</tbody><colgroup><col><col><col><col><col></colgroup>

Output needed as below;
Cust IDType Month-YearDayTotal Days
1LuxuryMar-1723,28,29,30,314
1LuxuryApr-178,10,11,124

<tbody>
</tbody><colgroup><col><col><col><col><col></colgroup>

Regards,
motherindia

<tbody>
</tbody><colgroup><col><col><col><col><col></colgroup>
 
Sort by date Sort by votes
Thanks once again Mick Sir.
You can go by days and if there is one half day only then you can show it as half day and if there is two line with half days, then you can combine it as one day and get the unique days for month.

Regards,
motherindia
 
Upvote 0

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
The result here would be as follows:-
Is that acceptable
Cust IDTypeMonth-YearDayTotal Days
1Luxury Mar-1723,28,29,30,314
1Luxury Apr-178,10,11,123
2Luxury Apr-161,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,22,23,24,25,26,27,28,29,3027
2Luxury May-161,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,3030
<colgroup><col width="49" style="width: 37pt; mso-width-source: userset; mso-width-alt: 1735;"> <col width="46" style="width: 34pt; mso-width-source: userset; mso-width-alt: 1621;"> <col width="78" style="width: 58pt; mso-width-source: userset; mso-width-alt: 2759;"> <col width="478" style="width: 358pt; mso-width-source: userset; mso-width-alt: 16981;"> <col width="69" style="width: 52pt; mso-width-source: userset; mso-width-alt: 2446;"> <tbody> </tbody>
 
Upvote 0
MickG said:
The logic of your last post is to count the number of days in the Unique month, in these two cases 27 & 30, but if you go back to "March" and "April" the Result from column "E" is Based on the Sum of the Values in "E". in those cases 4, because you have a number of "0.5's"
So you now have two criteria :- Sum or Days,
How do you want to resolve this ?????
Click to expand...

Yes sir will do.
 
Upvote 0
Try this for Results on sheet2:-
Code: 
[COLOR=navy]Sub[/COLOR] MG14Apr12
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Txt [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Dt [COLOR=navy]As[/COLOR] Date
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Frac [COLOR=navy]As[/COLOR] Double
c = 1
[COLOR=navy]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]For[/COLOR] Dt = Dn.Offset(, 2) To Dn.Offset(, 3)
        Txt = Dn.Value & ", " & MonthName(Month(Dt), True) & "-" & Right(Year(Dt), 2)
        [COLOR=navy]If[/COLOR] Not .Exists(Txt) [COLOR=navy]Then[/COLOR]
            Frac = IIf(Dn.Offset(, 4) = 0.5, 0.5, 0)
            .Add Txt, Array(Frac, Day(Dt), Dn)
        [COLOR=navy]Else[/COLOR]
             Q = .Item(Txt)
             [COLOR=navy]If[/COLOR] Not Dn.Address = Q(2).Address [COLOR=navy]Then[/COLOR]
                
                Q(0) = Q(0) + IIf(Dn.Offset(, 4) = 0.5, 0.5, 0) 
             [COLOR=navy]Set[/COLOR] Q(2) = Dn
             [COLOR=navy]End[/COLOR] If
             [COLOR=navy]If[/COLOR] InStr(Q(1), Day(Dt)) = 0 [COLOR=navy]Then[/COLOR]
                    Q(1) = Q(1) & "," & Day(Dt)
             [COLOR=navy]End[/COLOR] If
            .Item(Txt) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dt
[COLOR=navy]Next[/COLOR]
ReDim ray(1 To .Count + 1, 1 To 5)
ray(1, 1) = "Cust ID": ray(1, 2) = "Type": ray(1, 3) = "Month-Year": ray(1, 4) = "Day": ray(1, 5) = "Total Days"
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    c = c + 1
    ray(c, 1) = Split(K, ",")(0)
    ray(c, 2) = .Item(K)(2).Offset(, 1)
    ray(c, 3) = Split(K, ",")(1)
    ray(c, 4) = .Item(K)(1)
    ray(c, 5) = UBound(Split(.Item(K)(1), ",")) + 1 - .Item(K)(0)
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("a1").Resize(c, 5)
    .Value = ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
Hello Mick Sir,
Thank you all for your help -it has been much appreciated. Your code works fine now and also amazing code.
In fact I had labouriously trying it out just before I saw your post.
Thank you again for your help - problem solved!

Regards,
motherindia
 
Upvote 0
Hello Mick ,

Sorry to bother you once again. Is it possible to have combined consecutive days as single range ie if I have days like, 1,2,3,5,7,8,9 as 1-3,5,7-9 etc.. in another column (please refer the last column in below example )

Cust IDTypeMonth-YearDayTotal DaysDays Range
1LuxuryMar-1723,28,29,30,31423,28-31
1LuxuryApr-178,10,11,1248,10-12
2LuxuryApr-161,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,22,23,24,25,26,27,28,29,30271-18,22-30
2LuxuryMay-161,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30301-30

<tbody>
</tbody><colgroup><col span="3"><col><col><col></colgroup>


Thanks once again.

Regards,
motherindia.
 
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG04May27
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] TxT [COLOR=navy]As[/COLOR] [COLOR=navy]String,[/COLOR] Dt [COLOR=navy]As[/COLOR] Date
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, ac [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Q [COLOR=navy]As[/COLOR] Variant, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Frac [COLOR=navy]As[/COLOR] Double
c = 1
[COLOR=navy]Set[/COLOR] Rng = Range("A2", Range("A" & Rows.Count).End(xlUp))
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]For[/COLOR] Dt = Dn.Offset(, 2) To Dn.Offset(, 3)
        TxT = Dn.Value & ", " & MonthName(Month(Dt), True) & "-" & Right(Year(Dt), 2)
        [COLOR=navy]If[/COLOR] Not .Exists(TxT) [COLOR=navy]Then[/COLOR]
            Frac = IIf(Dn.Offset(, 4) = 0.5, 0.5, 0)
            .Add TxT, Array(Frac, Day(Dt), Dn)
        [COLOR=navy]Else[/COLOR]
             Q = .Item(TxT)
             [COLOR=navy]If[/COLOR] Not Dn.Address = Q(2).Address [COLOR=navy]Then[/COLOR]
                
                Q(0) = Q(0) + IIf(Dn.Offset(, 4) = 0.5, 0.5, 0)
             [COLOR=navy]Set[/COLOR] Q(2) = Dn
             [COLOR=navy]End[/COLOR] If
             [COLOR=navy]If[/COLOR] InStr(Q(1), Day(Dt)) = 0 [COLOR=navy]Then[/COLOR]
                    Q(1) = Q(1) & "," & Day(Dt)
             [COLOR=navy]End[/COLOR] If
            .Item(TxT) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] Dt
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] Mystrg [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
ReDim Ray(1 To .Count + 1, 1 To 5)
Ray(1, 1) = "Cust ID": Ray(1, 2) = "Type": Ray(1, 3) = "Month-Year": Ray(1, 4) = "Day": Ray(1, 5) = "Total Days"
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    c = c + 1
    Ray(c, 1) = Split(K, ",")(0)
    Ray(c, 2) = .Item(K)(2).Offset(, 1)
    Ray(c, 3) = Split(K, ",")(1)
    Mystrg = .Item(K)(1)
    Ray(c, 4) = jTxt(Mystrg)
    Ray(c, 5) = UBound(Split(.Item(K)(1), ",")) + 1 - .Item(K)(0)
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Sheets("Sheet2").Range("a1").Resize(c, 5)
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
[COLOR=navy]End[/COLOR] With
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]




Function jTxt(TxT [COLOR=navy]As[/COLOR] String) [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]Dim[/COLOR] n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, num [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Ray(), Q [COLOR=navy]As[/COLOR] Variant
[COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
  .CompareMode = vbTextCompare
    Sp = Split(TxT, ",")
[COLOR=navy]For[/COLOR] n = 0 To UBound(Sp)
    [COLOR=navy]If[/COLOR] .Count = 0 [COLOR=navy]Then[/COLOR]
        num = 1
    [COLOR=navy]ElseIf[/COLOR] n > 0 And Not Val(Sp(n)) = Val(Sp(n - 1)) + 1 [COLOR=navy]Then[/COLOR]
        num = num + 1: c = 0
    [COLOR=navy]End[/COLOR] If
        [COLOR=navy]If[/COLOR] Not .Exists(CStr(num)) [COLOR=navy]Then[/COLOR]
            c = c + 1
            ReDim Preserve Ray(c)
            Ray(c) = Sp(n)
           .Add CStr(num), Ray
        [COLOR=navy]Else[/COLOR]
           Q = .Item(CStr(num))
            c = c + 1
            ReDim Preserve Q(c)
           Q(c) = Sp(n)
       .Item(CStr(num)) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]Dim[/COLOR] K [COLOR=navy]As[/COLOR] Variant, nStr [COLOR=navy]As[/COLOR] [COLOR=navy]String[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] K [COLOR=navy]In[/COLOR] .keys
    nStr = nStr & ", " & IIf(.Item(K)(1) = .Item(K)(UBound(.Item(K))), .Item(K)(1), .Item(K)(1) & "-" & .Item(K)(UBound(.Item(K))))
[COLOR=navy]Next[/COLOR] K
[COLOR=navy]End[/COLOR] With
jTxt = Mid(nStr, 2)
[COLOR=navy]End[/COLOR] Function
Regards Mick
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
Assign Month number 1 to n based on sequential week range
Replies
6
Views
306
amolvijay
A
N
  • Locked
  • Question
Exccel - date formula that drives multiple other formulas
Replies
2
Views
211
Fluff
Fluff
A
  • Solved
AVERAGEIFS with 4 criteria
2
Replies
16
Views
443
Fluff
Fluff
A
  • Solved
Help Changing Cell Color to Based of Date referring to a specific Interior Cell Color
Replies
8
Views
379
SanjayGMusafir
SanjayGMusafir
J
  • Solved
Add 1 day to a date within a range as long as 2 conditions are met [without macros]
Replies
4
Views
619
juanam
J

Forum statistics

Threads
1,216,335
Messages
6,130,094
Members
449,557
Latest member
SarahGiles

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