Get all dates between 2 dates in vba

[Shantanu_4612]

I am a newbie in vba and I am trying to get in vba all dates between 2 dates, for example I will call the function with the parameters 01-01-2015 and 15-01-2015, and I will get in return an array with all the dates possibles, i.e :

This is the Data that I have;

ID	Start Date	End Date	Code
1234567	03-10-2016	15-10-2016	ABC_987654321
3456789	10-09-2016	20-09-2016	ABC_123456789

<tbody>
</tbody>

The Result should be as below, and should stop when finds blanks in start date

ID	Date	Code
1234567	03-10-2016	ABC_987654321
1234567	04-10-2016	ABC_987654321
1234567	05-10-2016	ABC_987654321
3456789	10-09-2016	ABC_123456789
3456789	11-09-2016	ABC_123456789
3456789	12-09-2016	ABC_123456789
3456789	13-09-2016	ABC_123456789
3456789	14-09-2016	ABC_123456789
3456789	15-09-2016	ABC_123456789
3456789	16-09-2016	ABC_123456789
3456789	17-09-2016	ABC_123456789
3456789	18-09-2016	ABC_123456789
3456789	19-09-2016	ABC_123456789
3456789	20-09-2016	ABC_123456789

<tbody>
</tbody>

Please help me with this its a bit urgent, my job is on stake

 

[MickG]

Try this for results starting "F1".

[COLOR="Navy"]Sub[/COLOR] MG03Oct07
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] Date
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
c = 1
Range("F1:H1") = Array("ID", "Date", "Code")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] Dt = Dn.Value To Dn.Offset(, 1).Value
        c = c + 1
        Cells(c, "F") = Dn.Offset(, -1).Value
        Cells(c, "G") = Dt
        Cells(c, "H") = Dn.Offset(, 2).Value
    [COLOR="Navy"]Next[/COLOR] Dt
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Shantanu_4612]

Thank You for your reply,

I am a bit new to this,

So could you please do few changes to the Script,

Start Data and End Data is in Sheet 1 (Named as UX_Dump)
Start Date(Leave From Date) is in BM Column and End Date (Leave to Date) is in BO Column,

ID (Employee No.) is in AQ Column and Code (Leave Application No.) is in BK Column.

I will be assigning the Button in Sheet 3 (Named Report) and Macro has to executed in Sheet 2 (Raw)

Please help

 

[MickG]

Try this :-
Data in sheet "UX_Dump", Results in sheet "Raw",Starting "A1"

[COLOR=navy]Sub[/COLOR] MG03Oct48
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, c [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dt [COLOR=navy]As[/COLOR] Date
[COLOR=navy]With[/COLOR] Sheets("UX_Dump")
        [COLOR=navy]Set[/COLOR] Rng = .Range(.Range("BM2"), .Range("BM" & Rows.Count).End(xlUp))
[COLOR=navy]End[/COLOR] With
ReDim ray(1 To 3, 1 To 1): c = 1
ray(1, 1) = "ID": ray(2, 1) = "Date": ray(3, 1) = "Code"
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
    [COLOR=navy]For[/COLOR] Dt = Dn.Value To Dn.Offset(, 2).Value
        c = c + 1
        ReDim Preserve ray(1 To 3, 1 To c)
        ray(1, c) = Dn.Offset(, -22).Value
        ray(2, c) = Dt
        ray(3, c) = Dn.Offset(, -2).Value
    [COLOR=navy]Next[/COLOR] Dt
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]With[/COLOR] Sheets("Raw").Range("A1").Resize(c, 3)
    .Value = Application.Transpose(ray)
    .Columns.AutoFit
    .Borders.Weight = 2
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[Shantanu_4612]

It is not working,

In RAW sheet, I want Employee No. in Column A, Date in Column B and Leave Application No. in Column C

If I run the Macro in Sheet 3 (Named Report)

So Sheet 1 is UX_Dump
Sheet 2 is Raw
Sheet 3 is WFM_Dump (Macro to be Run)

And if possible can be add a timer of 5 Mins and executing the Macro,
i.e. We run the Macro, Timer Displays, So we give it a time of

 

[MickG]

What are the results you get at the moment???

 

[Shantanu_4612]

Sorry for late reply,

For the second scripts that you gave me, it just gave me an error that it cannot be run,

and the first script, it is working, but it is killing my computer and is taking ages to run,

I have a data of, 5,00,000 entries, and have to run this macro on my office computer which does not have a good config,

It is killing it, its config is so bad, that its taking 2 mins to complete entry in one cell.

Please help,

 

[MickG]

If you have 1/2 million lines in your data and there at 10 dates in each that is 5 million rows in a worksheet with just over 1 million rows.
Is 1/2 million rows correct ???

 

[Shantanu_4612]

If you have 1/2 million lines in your data and there at 10 dates in each that is 5 million rows in a worksheet with just over 1 million rows.
Is 1/2 million rows correct ???

Yes, approximately!
But the dates are varying from 0.5(half day) to 90 days,
So yes it's a huge data
So please help me with a solution

 

[MickG]

Try this on a small sample to make sure you getting the right results on sheet "Raw".
NB:- If the results in "Raw" get over one million rows the results Move 3 columns across and starting again with row1.
I have tried this on 200K rows giving a result of approx. 2.4 million rows.
The code took about 3Minutes to run.

[COLOR="Navy"]Sub[/COLOR] MG05Oct57
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] Date, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] t
ac = 1
t = Timer
Application.ScreenUpdating = False
[COLOR="Navy"]With[/COLOR] Sheets("UX_Dump")
        [COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("BM2"), .Range("BM" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
c = 1
[COLOR="Navy"]With[/COLOR] Sheets("Raw")
.Range("A1:C1").Value = Array("ID", "Date", "Code")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]For[/COLOR] Dt = Dn.Value To Dn.Offset(, 2).Value
        c = c + 1
        [COLOR="Navy"]If[/COLOR] c >= 1000000 [COLOR="Navy"]Then[/COLOR] ac = ac + 3: c = 1
        .Cells(c, ac) = Dn.Offset(, -22).Value
        .Cells(c, ac + 1) = Dt
        .Cells(c, ac + 2) = Dn.Offset(, -2).Value
    [COLOR="Navy"]Next[/COLOR] Dt
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
Application.ScreenUpdating = True
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick