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.

 

[motherindia]

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

Hi Rick,

If I want to add 2 more columns ,how should I alter the code.

Regards,
motherindia

 

[RickXL]

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

First, you need to decide some things:

Where will the extra columns come from? Will it be possible to just increase the number of columns read by two or are they not next to the original columns?
Will the extra columns take any part in the processing or are they just descriptive?
What is the desired order of the output columns?

 

[motherindia]

Thanks for quick responses Rick.
Sorry for the delayed responses. The 2 additional columns are same in both sheets and are descriptives only.

Regards,
motherindia

 

[RickXL]

Try this:

Sub Test12()
    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
    Dim v1P   As String
    Dim v2P   As String
    Dim v1C   As String
    Dim v2C   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")
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 6)
    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, arr(i, 5), arr(i, 6))
        Next
    Next

    With ThisWorkbook.Worksheets("Sheet2")
        arr = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 6)
    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, arr(i, 5), arr(i, 6))
            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)
        v1C = dic1.Item(vKey)(4)
        v2C = dic1.Item(vKey)(5)
        If ft Then
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            v1P = v1C
            v2P = v2C
            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
            v1P = v1C
            v2P = v2C
        Else
            dic3(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP, v1C, v2C)
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            v1P = v1C
            v2P = v2C
            cu = dic1.Item(vKey)(2)
        End If
    Next
    dic3(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP, v1P, v2P)

    idP = ""
    ft = True
    For Each vKey In dic2.Keys
        idC = dic2.Item(vKey)(0)
        dtC = dic2.Item(vKey)(1)
        shC = dic2.Item(vKey)(3)
        v1C = dic2.Item(vKey)(4)
        v2C = dic2.Item(vKey)(5)
        If ft Then
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            v1P = v1C
            v2P = v2C
            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
            v1P = v1C
            v2P = v2C
        Else
            dic4(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP, v1C, v2C)
            idP = idC
            dt1 = dtC
            dt2 = dtC
            dtP = dtC
            shP = shC
            v1P = v1C
            v2P = v2C
            cu = dic2.Item(vKey)(2)
        End If
    Next
    dic4(idC & "|" & dt1) = Array(idP, CLng(dt1), CLng(dt2), cu, shP, v1C, v2C)

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 7) = Array("ID", "S Date", "E Date", "Days", "Sheet", "Var 1", "Var 2")
        .Range("A2").Resize(dic3.Count, 7) = Application.Index(dic3.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        .Columns("A:I").AutoFit
    End With

    With ThisWorkbook.Worksheets("Sheet4")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 7) = Array("ID", "S Date", "E Date", "Days", "Sheet", "Var 1", "Var 2")
        .Range("A2").Resize(dic4.Count, 7) = Application.Index(dic4.Items, 0, 0)
        .Columns("B:C").NumberFormat = "DD-MMM-YY"
        .Columns("A:I").AutoFit
    End With

End Sub

Regards,

 

[motherindia]

Great Sir.
This is what I expected. Once again very much grateful to you.

Regards,
motherindia

 

[RickXL]

No problem.

Thanks for the feedback.

Regards,

 

[motherindia]

Hi Rick Sir,

I have asked one more question which I asked separately on this Forum.
No one has responded so far .
Following is the link which I have asked the question.
http://www.mrexcel.com/forum/excel-...ch-column-names-based-sheet4-then-do-sum.html

Please let me know if it is possible.

Thanks once again.

Regards,
motherindia