Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

[motherindia]

Dear All,

I need VBA code for comparing start date and end date range between 2 sheets for each id
to compare ID , start date and end date of sheet 1 with sheet and copy missing date in separate sheet.
following is the example shown which is what i need. I VBA code as the data is 40k-to 50k comparison.

please help me out.



Sheet1
ID St date End date
1 01-04-2015 03-04-2015
1 04-04-2015 07-04-2015
2 06-04-2015 15-04-2015



Sheet2
ID St date End date
1 01-04-2015 10-04-2015
2 01-04-2015 03-04-2015
2 04-04-2015 07-04-2015
2 09-04-2015 13-04-2015

Output on separate sheet

ID Date Missing Remarks
1 08-04-2015 Not in Sheet1
1 09-04-2015 Not in Sheet1
1 10-04-2015 Not in Sheet1
2 08-04-2015 Not in Sheet2
2 14-04-2015 Not in Sheet2
2 15-04-2015 Not in Sheet2



Regards,
Motherindia

 

[motherindia]

Yes Mick Sir.
It's Perfect !!!! Thank You so much once again
You are truly amazing Sir. If possible ( else no problem ) can u please explain the use of "fd=false" and "Rng.Parent.Name".
Thank you once again.


Regards,
MotherIndia.

 

[motherindia]

Thanks once again Mick Sir.

 

[Oeldere]

Maybe you can add the link also in this topic so MickG also can see you asked the same question in another topic.

http://www.mrexcel.com/forum/excel-...applications-help-required-speed-up-code.html

 

[motherindia]

Hello Mike Sir,
Need your help to speed up the following code which is written by you. When I tested it on real data about 1 lakh rows the macro running for many hrs. Following is the code for your info.

Sub MG14Nov57
Dim Dn As Range, Sp As Variant
Dim Fd As Boolean
Dim Rng As Range
Dim Dic As Object
Dim k As Variant
Dim p As Variant, c As Long
Dim Q As Variant, oDts As String
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
For Each Dn In Rng
If Not Dic.exists(Dn.Value) Then
Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
End If
oDts = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
If Not Dic(Dn.Value).exists(oDts) Then
Dic(Dn.Value).Add (oDts), Array(Dn.Offset(, 3).Value, Rng.Parent.Name)
End If
Next Dn

With Sheets("Sheet2")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
Fd = False
For Each k In Dic.Keys
For Each p In Dic(k)
Sp = Split(p, "_")
If Dn.Value = k And CDate(Dn.Offset(, 1).Value) >= Sp(0) And CDate(Dn.Offset(, 2).Value) <= Sp(1) Then
Q = Dic(k).Item(p)
Q(0) = Q(0) - Dn.Offset(, 3).Value
Dic(k).Item(p) = Q
Fd = True
Exit For
End If
Next p
Next k
oDts = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
If Fd = False Then
If Not Dic.exists(Dn.Value) Then
Set Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
End If
oDts = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
If Not Dic(Dn.Value).exists(oDts) Then
Dic(Dn.Value).Add (oDts), Array(Dn.Offset(, 3).Value, Rng.Parent.Name)
End If
End If

Next Dn


c = 1
With Sheets("Sheet3")
For Each k In Dic.Keys
For Each p In Dic(k)
If Dic(k).Item(p)(0) > 0 Then
c = c + 1
.Cells(c, "A") = k
.Cells(c, "B") = p
.Cells(c, "C") = Dic(k).Item(p)
.Cells(c, "D") = "Not in Sheet" & IIf(Dic(k).Item(p)(1) = "Sheet1", 2, 1)
End If
Next p
Next k
End With
End Sub


http://www.mrexcel.com/forum/excel-...applications-help-required-speed-up-code.html

 

[MickG]

Try this:-
NB:- Tested on limited data only"

[COLOR="Navy"]Sub[/COLOR] MG22May10
'[COLOR="Green"][B]Array Version[/B][/COLOR]
 [COLOR="Navy"]Dim[/COLOR] Sp         [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]Dim[/COLOR] Fd         [COLOR="Navy"]As[/COLOR] Boolean
 [COLOR="Navy"]Dim[/COLOR] Dic        [COLOR="Navy"]As[/COLOR] Object
 [COLOR="Navy"]Dim[/COLOR] k          [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]Dim[/COLOR] p          [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 [COLOR="Navy"]Dim[/COLOR] Q          [COLOR="Navy"]As[/COLOR] Variant, oDts [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
 [COLOR="Navy"]Dim[/COLOR] Ray        [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]Dim[/COLOR] n          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet1")
 Ray = .Range("A1").CurrentRegion.Resize(, 4)
 [COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
 Dic.CompareMode = 1
 [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
    [COLOR="Navy"]End[/COLOR] If
    oDts = Ray(n, 2) & "_" & Ray(n, 3)
    [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, 1)).exists(oDts) [COLOR="Navy"]Then[/COLOR]
        Dic(Ray(n, 1)).Add (oDts), Array(Ray(n, 4), "Sheet1")
    [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]Next[/COLOR] n

 [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
    Ray = .Range("A1").CurrentRegion.Resize(, 4)
 [COLOR="Navy"]End[/COLOR] With
 [COLOR="Navy"]For[/COLOR] n = 2 To UBound(Ray, 1)
        Fd = False
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
                Sp = Split(p, "_")
                [COLOR="Navy"]If[/COLOR] Ray(n, 1) = k And CDate(Ray(n, 2)) >= Sp(0) And CDate(Ray(n, 3)) <= Sp(1) [COLOR="Navy"]Then[/COLOR]
                    Q = Dic(k).Item(p)
                        Q(0) = Q(0) - Ray(n, 4)
                    Dic(k).Item(p) = Q
                    Fd = True
                    [COLOR="Navy"]Exit[/COLOR] For
                [COLOR="Navy"]End[/COLOR] If
            [COLOR="Navy"]Next[/COLOR] p
        [COLOR="Navy"]Next[/COLOR] k
 oDts = Ray(n, 2) & "_" & Ray(n, 3)
 [COLOR="Navy"]If[/COLOR] Fd = False [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not Dic.exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]Set[/COLOR] Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
    [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]If[/COLOR] Not Dic(Ray(n, 1)).exists(oDts) [COLOR="Navy"]Then[/COLOR]
            Dic(Ray(n, 1)).Add (oDts), Array(Ray(n, 4), "Sheet2")
        [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n

ReDim nray(1 To UBound(Ray, 1) * 2, 1 To 4)
 nray(1, 1) = "ID": nray(1, 2) = "S_E Date": nray(1, 3) = "Days": nray(1, 4) = "Not [COLOR="Navy"]In[/COLOR] !!"
 c = 1
 [COLOR="Navy"]With[/COLOR] Sheets("Sheet3")
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.Keys
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
            [COLOR="Navy"]If[/COLOR] Dic(k).Item(p)(0) > 0 [COLOR="Navy"]Then[/COLOR]
                 c = c + 1
'[COLOR="Green"][B]NB:- If code fails to complete, Try the ".cells" code below in place of array "nRay"[/B][/COLOR]
'[COLOR="Green"][B] .Cells(c, "A") = k[/B][/COLOR]
'[COLOR="Green"][B] .Cells(c, "B") = p[/B][/COLOR]
'[COLOR="Green"][B] .Cells(c, "C") = Dic(k).Item(p)(0)[/B][/COLOR]
'[COLOR="Green"][B] .Cells(c, "D") = "Not in Sheet" & IIf(Dic(k).Item(p)(1) = "Sheet1", 2, 1)[/B][/COLOR]
                nray(c, 1) = k
                nray(c, 2) = p
                nray(c, 3) = Dic(k).Item(p)(0)
                nray(c, 4) = "Not in Sheet" & IIf(Dic(k).Item(p)(1) = "Sheet1", 2, 1)
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k
 .Range("A1").Resize(c, 4).Value = nray
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[motherindia]

Hi Mick,
Thanks for quick responses. I initially tested on small data as below;

In Sheet1

E# S Date E Date Days worked
1212820559 17-Aug-15 17-Aug-15 1.00
1212820559 21-Aug-15 22-Aug-15 1.50
1212820559 29-Aug-15 31-Aug-15 3.00
1212820559 01-Sep-15 01-Sep-15 1.00
1213904557 17-Aug-15 17-Aug-15 1.00
1213904557 29-Aug-15 31-Aug-15 3.00
1214913888 29-Aug-15 31-Aug-15 3.00


in Sheet2

E# S Date E Date Days worked
1212820559 18-Aug-15 20-Aug-15 3.00
1212820559 21-Aug-15 21-Aug-15 1.00
1212820559 23-Aug-15 28-Aug-15 7.00
1212820559 29-Aug-15 31-Aug-15 3.00
1212820559 01-Sep-15 01-Sep-15 1.00
1213904557 01-Sep-15 01-Sep-15 1.00

When I run the macro I get result as below;

E# Date Missing Days worked Remarks
1212820559 17-Aug-15_17-Aug-15 1 Not in Sheet2
1212820559 21-Aug-15_22-Aug-15 0.5 Not in Sheet2
1212820559 18-Aug-15_20-Aug-15 3 Not in Sheet1
1212820559 23-Aug-15_28-Aug-15 7 Not in Sheet1
1213904557 17-Aug-15_17-Aug-15 1 Not in Sheet2
1213904557 29-Aug-15_31-Aug-15 3 Not in Sheet2
1213904557 01-Sep-15_01-Sep-15 1 Not in Sheet1
1214913888 29-Aug-15_31-Aug-15 3 Not in Sheet2

But actual output should have been as below;

E# Date Missing Days worked Remarks
1212820559 17-Aug-15_17-Aug-15 1 Not in Sheet2
1212820559 22-Aug-15_22-Aug-15 0.5 Not in Sheet2
1212820559 18-Aug-15_20-Aug-15 3 Not in Sheet1
1212820559 23-Aug-15_28-Aug-15 7 Not in Sheet1
1213904557 17-Aug-15_17-Aug-15 1 Not in Sheet2
1213904557 29-Aug-15_31-Aug-15 3 Not in Sheet2
1213904557 01-Sep-15_01-Sep-15 1 Not in Sheet1
1214913888 29-Aug-15_31-Aug-15 3 Not in Sheet2

PS: Half day is assigned to last date in date range.

Again when I tested in huge data , the macro is still very very slow and keeps running and still running.

Sorry to bother you again. Is there way to speed up the macro without looping.

Regards,
motherindia.

 

[motherindia]

Can anyone pls help us out.

 

[Peter_SSs]

Duplicate to http://www.mrexcel.com/forum/excel-questions/945246-scripting-dictionay-visual-basic-applications-matching-start-date-end-date-range-between-2-sheets-each-id.html

Please do not post the same question multiple times. Questions of a duplicate nature will be locked or deleted, per #12 of the Forum Rules and points 6 & 7 of the Forum Use Guidelines.

Any bumps, clarifications, or follow-ups should be posted to the linked thread.