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

[motherindia]

Dear Mike Sir,

Can you please help me in getting the expected result.



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.

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


Here is the code written by you;

http://www.mrexcel.com/forum/excel-...nd-date-range-between-2-sheets-each-id-2.html


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

With Sheets("Sheet2")
Ray = .Range("A1").CurrentRegion.Resize(, 4)
End With
For n = 2 To UBound(Ray, 1)
Fd = False
For Each k In Dic.Keys
For Each p In Dic(k)
Sp = Split(p, "_")
If Ray(n, 1) = k And CDate(Ray(n, 2)) >= Sp(0) And CDate(Ray(n, 3)) <= Sp(1) Then
Q = Dic(k).Item(p)
Q(0) = Q(0) - Ray(n, 4)
Dic(k).Item(p) = Q
Fd = True
Exit For
End If
Next p
Next k
oDts = Ray(n, 2) & "_" & Ray(n, 3)
If Fd = False Then
If Not Dic.exists(Ray(n, 1)) Then
Set Dic(Ray(n, 1)) = CreateObject("Scripting.Dictionary")
End If
If Not Dic(Ray(n, 1)).exists(oDts) Then
Dic(Ray(n, 1)).Add (oDts), Array(Ray(n, 4), "Sheet2")
End If
End If
Next 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 In !!"
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
'NB:- If code fails to complete, Try the ".cells" code below in place of array "nRay"
' .Cells(c, "A") = k
' .Cells(c, "B") = p
' .Cells(c, "C") = Dic(k).Item(p)(0)
' .Cells(c, "D") = "Not in Sheet" & IIf(Dic(k).Item(p)(1) = "Sheet1", 2, 1)
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)
End If
Next p
Next k
.Range("A1").Resize(c, 4).Value = nray
End With
End Sub



Regards,
motherindia.

 

[RickXL]

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

Just the one line

Dim dic As New Dictionary

is quite adequate.

It usually works but it is generally considered bad practice.

Dim as New ... does not instantiate the object at that time. It happens when you first use it. That may be OK or it may not. If you test whether an object is Nothing it will create it for you at that time which is not what you want.

I am a simple soul. I have two versions that work and don't have issues (as far as I know) so I just use them every time.

Recently, for my postings here, I have standardised (apart from the odd mistake) on late binding. This means that I don't have to explain how to set References in the VB Editor for every piece of code. It also means that the code will usually work across different Excel versions without issue. That is an advantage if the code is rolled out to different machines with different build standards.

Consequently I will stick to:

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

But I may suggest:

Dim dic As Dictionary
Set dic = New Dictionary

if someone has an issue with processing speed.

Regards,

 

[motherindia]

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

Thanks Rick. But the error is not for above. Is it possible to split the output to 2 or more sheets if output of macro is more than 10 lakh.

 

[RickXL]

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

Probably.

I am not sure what you mean when you say: "But the error is not for above."

I am looking into re-summarising the output so that each entry will have a start date and an end date with the correctly summarised hours. I don't know how long it will take to run the code and I don't have enough data for a good test.

What I would be interested in knowing is why you are comparing two files that have over a million differences? Is someone going to investigate each one? If you spend a minute on each doesn't that come to about 10 man years of effort?

 

[motherindia]

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

First & for most sorry for making you trouble so much. The macro does what I expected. But what I meant to say is that after running macro if final output has more than 11 lakh rows it will not work. So this is only my concerns.

 

[motherindia]

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

Hi Rick,
Sorry to trouble you again.

Can I have the output in 2 sheets ie one not matching as per "Sheet1" and another for not matching as per "Sheet2".

Regards,
motherindia.

 

[RickXL]

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

Hi,

Please try this one first. It cumulates the data.

If you still need a two sheet version after you have tried this I can do that as well.

Sub Test9()
    Dim arr   As Variant
    Dim i     As Long
    Dim j     As Long
    Dim dys   As Double
    Dim dy    As Double
    Dim dic1  As Object
    Dim dic2  As Object
    Dim key   As String
    Dim vKey  As Variant
    Dim idC   As String
    Dim idP   As String
    Dim dt1   As Date
    Dim dt2   As Date
    Dim dtC   As Date
    Dim dtP   As Date
    Dim cu    As Double
    Dim ft    As Boolean
    Dim shP   As String
    Dim shC   As String

    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets("Sheet1")
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        dys = arr(i, 4)
        For j = arr(i, 2) To arr(i, 3)
            dys = dys - 1
            If dys >= 0 Then dy = 1 Else dy = -dys
            key = arr(i, 1) & "|" & j & "|" & dy
            dic1(key) = Array(arr(i, 1), j, dy, "Not in Sheet2")
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet2")
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        dys = arr(i, 4)
        For j = arr(i, 2) To arr(i, 3)
            dys = dys - 1
            If dys >= 0 Then dy = 1 Else dy = -dys
            key = arr(i, 1) & "|" & j & "|" & dy
            If dic1.exists(key) Then
                dic1.Remove key
            Else
                dic1(key) = Array(arr(i, 1), j, dy, "Not in Sheet1")
            End If
        Next
    Next

    idP = ""
    ft = True
    For Each vKey In dic1.Keys
        idC = dic1.Item(vKey)(0)
        dtC = dic1.Item(vKey)(1)
        shC = dic1.Item(vKey)(3)
        If ft Then
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic1.Item(vKey)(2)
            ft = False
        End If
        If (idC = idP) And (dtC = dtP + 1) And (shC = shP) Then
            cu = cu + dic1.Item(vKey)(2)
            dt2 = dtC
            dtP = dtC
            shP = shC
        Else
            dic2(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic1.Item(vKey)(2)
        End If
    Next
    dic2(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 4) = Array("ID", "S Date", "E Date", "Days", "Sheet")
        .Range("A2").Resize(dic2.Count, 5) = Application.Index(dic2.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        .Columns("A:I").AutoFit
    End With

End Sub

My original idea was to sort both input sheets before starting the processing. However, if the sheets are in roughly the right order then it should still work (?). I am relying on your testing!
Commenting out the sort steps saves a lot of time.

I don't think that Dictionaries have a 1048576 entry limit because they are not a part of Excel. They probably work until you run out of memory.
The first data sheet is read into a Dictionary and converted to individual day records. Then the second sheet is read and any matches are removed. Finally, the data is summarised into groups of days and displayed.

Regards,

 

[motherindia]

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

Hi Rick.
Thanks for quick responses and code run without any issues. But I see the macro gives different result.
For Eg:
Sheet1
E# S Date E date Days
9999999999 18-12-14 23-01-15 36.5

Sheet2
E# S Date E date Days
9999999999 18-12-14 04-01-15 17.5
9999999999 15-01-15 23-01-15 9

Result should have been

ID S Date E Date Days Sheet
9999999999 04-Jan-15 04-Jan-15 1 Not in Sheet2
9999999999 04-Jan-15 04-Jan-15 0.5 Not in Sheet1
9999999999 05-Jan-15 14-Jan-15 10 Not in Sheet2
9999999999 23-Jan-15 23-Jan-15 0.5 Not in Sheet2
9999999999 23-Jan-15 23-Jan-15 1 Not in Sheet1

but I am getting result as "

ID S Date E Date Days
170709 04-Jan-15 04-Jan-15 0.5 Not in Sheet1
170709 23-Jan-15 23-Jan-15 1 Not in Sheet1



regards,
motherindia

 

[motherindia]

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

Sorry result showing as
ID S Date E Date Days
9999999999 04-Jan-15 04-Jan-15 0.5 Not in Sheet1
9999999999 23-Jan-15 23-Jan-15 1 Not in Sheet1

As said Can I have result in 2 sheets separately as well.

Regards

 

[RickXL]

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

This is quite close now.

I am not quite sure how to perform the comparisons because your criteria are a bit quirky. It looks as if you want whole days to be summarised together if they are contiguous but if the other sheet has a half day on one of those days then you want the range on the other sheet to be split even though it was entered as a single date range.

So, I have managed part of that and have now split the output into two sheets - Sheet3 and Sheet4.

I have removed the sheet indicator column as well because it is no longer necessary and will slow the processing slightly. As it is, processing time has increased by 50% with my small data file.

Sub Test10()
    Dim arr   As Variant
    Dim arrT  As Variant
    Dim i     As Long
    Dim j     As Long
    Dim dys   As Double
    Dim dy    As Double
    Dim dic1  As Object
    Dim dic2  As Object
    Dim dic3  As Object
    Dim dic4  As Object
    Dim key   As String
    Dim vKey  As Variant
    Dim idC   As String
    Dim idP   As String
    Dim dt1   As Date
    Dim dt2   As Date
    Dim dtC   As Date
    Dim dtP   As Date
    Dim cu    As Double
    Dim ft    As Boolean
    Dim shP   As String
    Dim shC   As String

    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = CreateObject("Scripting.Dictionary")
    Set dic3 = CreateObject("Scripting.Dictionary")
    Set dic4 = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets("Sheet1")
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        dys = arr(i, 4)
        For j = arr(i, 2) To arr(i, 3)
            dys = dys - 1
            If dys >= 0 Then dy = 1 Else dy = -dys
            key = arr(i, 1) & "|" & j & "|" & dy
            dic1(key) = Array(arr(i, 1), j, dy, 1)
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet2")
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        dys = arr(i, 4)
        For j = arr(i, 2) To arr(i, 3)
            dys = dys - 1
            If dys >= 0 Then dy = 1 Else dy = -dys
            key = arr(i, 1) & "|" & j & "|" & dy
            If dic1.exists(key) Then
                dic1.Remove (key)
            Else
                dic2(key) = Array(arr(i, 1), j, dy, 2)
            End If
        Next
    Next

    idP = ""
    ft = True
    For Each vKey In dic1.Keys
        idC = dic1.Item(vKey)(0)
        dtC = dic1.Item(vKey)(1)
        shC = dic1.Item(vKey)(3)
        If ft Then
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic1.Item(vKey)(2)
            ft = False
        End If
        If (idC = idP) And (dtC = dtP + 1) And (shC = shP) And (dic1.Item(vKey)(2) = 1) Then
            cu = cu + dic1.Item(vKey)(2)
            dt2 = dtC
            dtP = dtC
            shP = shC
        Else
            dic3(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic1.Item(vKey)(2)
        End If
    Next
    dic3(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)

    idP = ""
    ft = True
    For Each vKey In dic2.Keys
        idC = dic2.Item(vKey)(0)
        dtC = dic2.Item(vKey)(1)
        shC = dic2.Item(vKey)(3)
        If ft Then
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic2.Item(vKey)(2)
            ft = False
        End If
        If (idC = idP) And (dtC = dtP + 1) And (shC = shP) And (dic2.Item(vKey)(2) = 1) Then
            cu = cu + dic2.Item(vKey)(2)
            dt2 = dtC
            dtP = dtC
            shP = shC
        Else
            dic4(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            cu = dic2.Item(vKey)(2)
        End If
    Next
    dic4(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP)

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 5) = Array("ID", "S Date", "E Date", "Days", "Sheet")
        .Range("A2").Resize(dic3.Count, 5) = Application.Index(dic3.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        .Columns("A:I").AutoFit
    End With

    With ThisWorkbook.Worksheets("Sheet4")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 5) = Array("ID", "S Date", "E Date", "Days", "Sheet")
        .Range("A2").Resize(dic4.Count, 5) = Application.Index(dic4.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        '.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
        .Columns("A:I").AutoFit
    End With

End Sub

 

[motherindia]

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

Hi Rick,
Sorry for the delayed responses.
Thanks a ton. Yes I tested it on real data having 2-3 lakhs and it took just 15-20 min to complete data validations.
Once again you are truly my time and life saver. Great job and amazing code and processed at very high speed.
God Bless you.

Regards,
motherindia