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

Hi,

I think some looping will always be necessary. However, if you can work with a sightly different output there may be a way to speed things up.

The following code treats all the columns of the input data as a key. It then compares keys and displays the results, omitting the matching keys. So it is not as sophisticated as it could be but it does save time. It sorts the records that may differ close together.
Note, the content of column E is just a number. A format converts it into the string you see.

Sub test()
    Dim arr  As Variant
    Dim i    As Long
    Dim dic  As Object
    Dim Key  As String
    
    Set dic = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Sheet1")
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        Key = arr(i, 1) & Chr(0) & arr(i, 2) & Chr(0) & arr(i, 3) & Chr(0) & arr(i, 4)
        dic(Key) = Array(arr(i, 1), CLng(arr(i, 2)), CLng(arr(i, 3)), arr(i, 4), -1)
    Next

    With ThisWorkbook.Worksheets("Sheet2")
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4)
    End With

    For i = 1 To UBound(arr)
        Key = arr(i, 1) & Chr(0) & arr(i, 2) & Chr(0) & arr(i, 3) & Chr(0) & arr(i, 4)
        If dic.exists(Key) Then
            dic.Remove (Key)
        Else
            dic(Key) = Array(arr(i, 1), CLng(arr(i, 2)), CLng(arr(i, 3)), arr(i, 4), 1)
        End If
    Next

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .UsedRange.ClearContents
        .Range("A1").Resize(, 5) = Array("ID", "S Date", "E Date", "Days", "Location")
        .Range("A2").Resize(dic.Count, 5) = Application.Index(dic.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        .Columns("E").NumberFormat = "[Red]""Not in Sheet2"";""Not in Sheet1"""
        .Columns("A:E").AutoFit
        .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 5).Sort _
            Key1:=.Range("A1"), Key2:=.Range("B1"), Header:=xlYes
    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 Sir,

Thanks a lot for quick responses and code is bit fast.
However I need to check each date within the date ranges , if found then it has to match number of days .
After running macro result is not what I expected. Let me explain you with one example.


1212820559 21-Aug-15 22-Aug-15 1.50 means he worked for 1.5 days ie 21st Aug full and 22nd Aug half day in Sheet1.
But in SHeet2 the data is "1212820559 21-Aug-15 21-Aug-15 1.00" which means he worked for 1 full day on 21st Aug.

The macro should highlight the differences as

1212820559 22-Aug-15 22-Aug-15 0.5 Not in Sheet2

instead of

1212820559 21-Aug-15 22-Aug-15 1.5 Not in Sheet1.

Please let me know you need any details.

Regards,
motherindia

 

[RickXL]

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

What the report shows is:

Excel 2013
	A	B	C	D	E
104	1212820559	21-Aug-15	22-Aug-15	1.5	Not in Sheet1
105	1212820559	21-Aug-15	21-Aug-15	1	Not in Sheet2
Sheet3

So the difference is highlighted but it does not presume which one is correct. That is one of the "liberties" I took with your request.

The problem is that any changes I make to the code will slow it down. I have used the same objects and techniques as MickG but gained some speed by streamlining the requirements. If I re-instate all the functionality that you want you will probably have a solution that is again slow.

It is a compromise. It is up to you where you want to draw the line.

Regards,

 

[motherindia]

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

Thanks Once again Rick for quick responses. I am extremely satisfied with with your code .
I need a small favour. Can I get one more macro to convert following data

1212820559 21-Aug-15 22-Aug-15 1.5 Not in Sheet1 as

1212820559 21-Aug-15 22-Aug-15 1
1212820559 22-Aug-15 22-Aug-15 0.5

This would help me to reconcile the output data without much difficulty.

Regards,
motherindia

 

[RickXL]

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

OK, try this one.

There is no easy way to check for overlapping data and Dictionaries always work with exact keys so I split the input data into individual days. Any fractional days were assigned to the last day of the range. After that you can use Dictionaries again to perform exact matching.

I tried this some time ago but it took much longer to run that the previous version I posted but it can be optimised and, to my surprise, it has ended up about as quick as the previous version on my PC.

Sub Test()
    Dim arr  As Variant
    Dim i    As Long
    Dim j    As Long
    Dim dys  As Double
    Dim dy   As Double
    Dim dic  As Object
    Dim key  As String

    Set dic = CreateObject("Scripting.Dictionary")
    
    With ThisWorkbook.Worksheets("Sheet1")
        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
            dic(key) = Array(arr(i, 1), j, dy, "Not in Sheet2")
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet2")
        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 dic.exists(key) Then
                dic.Remove (key)
            Else
                dic(key) = Array(arr(i, 1), j, dy, "Not in Sheet1")
            End If
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 4) = Array("ID", "Date", "Days", "Sheet")
        .Range("A2").Resize(dic.Count, 4) = Application.Index(dic.Items, 0, 0)
        .Columns("B").NumberFormat = "DD-MMM-YY"
        .Columns("A:D").AutoFit
        .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
    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,
You are truly great Sir.
Don't know how to thank you. The code is extremely speed and working without any issues. I hv tested on small data it's beyond my imaginations. The results were what I expected.

Thanks once again . I can sleep with peace.
God Bless you Sir.
Regards,
motherindia

 

[motherindia]

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

Hello Rick.
Sorry to bother you again. When I tested on real data on 1 lakh rows I am getting error "Runtime error 1004, application defined error or object define error" at
.Range("A2").Resize(dic.Count, 4) = Application.Index(dic.Items, 0, 0)

Can you please help me to fix this bug.

Regards,
motherindia

 

[RickXL]

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

Is it possible for you to post your data somewhere (e.g. DropBox, OneDrive etc) so that I can replicate the issue?

Thanks.

 

[motherindia]

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

Thanks Rick for quick responses. Not sure whether I can share the data. However, I find one observation ie if I try with rows of 20k, it works and since differences are around 5 lakh rows it worked. may be it is the problem with Application.index as it cannot handle huge data.

Macro stops at the last stage ie while copying the diffrences in Sheet3.

motherindia