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

M

motherindia

Board Regular
Joined
Oct 15, 2015
Messages
218
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.
 
Sort by date Sort by votes
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

It could be, I have not used it before so I am unsure of its limits.

I can make it work differently - but it will mean another loop. :(
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

Thanks Rick. Waiting for your reply :cool::cool::cool:
 
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

Hello Sir,

I have 2 sheets in workbook which I need to compare. I need to identify missing highlight in color and provide the un matching date .


Eno 01-Sep-14 02-Sep-14 03-Sep-14 04-Sep-14 05-Sep-14 06-Sep-14 07-Sep-14 08-Sep-14 09-Sep-14 10-Sep-14 11-Sep-14 12-Sep-14 13-Sep-14 14-Sep-14 15-Sep-14 16-Sep-14 17-Sep-14 18-Sep-14 19-Sep-14 20-Sep-14 21-Sep-14 22-Sep-14 23-Sep-14 24-Sep-14 25-Sep-14 26-Sep-14 27-Sep-14 28-Sep-14 29-Sep-14 30-Sep-14
1 HS OS OS OS WO WO HS 10.15 10.15 OS HS OS WO HS HS HS HL HS WO WO HS HS HS HS HL WO WO HS HS EL 01-09-15 23-09-15




Sheet2

Emp no Type from date to date
1 OS 01-03-14 04-Sep-14
1 OS 10-09-14 11-09-14
1 HL 17-09-14 21-09-14



Result
E# Type Daysmissing
1 OS 10-09-2014,12-09-14
1 HL 25-Sep-14

I need it for all different type of leave (OS,HL etc...)

I need it to highlight the same Sheet1 against above date with color.


I need to compare Empno, Type whether it is matching in Sheet2 . If not highlight in Color and update the missing date in separate sheet.

Regards,
Motherindia
 
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

New code that should not stop at 20k:
Code: 
Sub Test7()
    Dim arr  As Variant
    Dim i    As Long
    Dim j    As Long
    Dim dys  As Double
    Dim dy   As Double
    Dim dic  As Dictionary
    Dim key  As String
    Dim vKey As Variant

    Set dic = New Dictionary '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

    ReDim arr2(1 To dic.Count, 1 To 4)
    i = 1
    For Each vKey In dic
        arr2(i, 1) = dic(vKey)(0)
        arr2(i, 2) = dic(vKey)(1)
        arr2(i, 3) = dic(vKey)(2)
        arr2(i, 4) = dic(vKey)(3)
        i = i + 1
    Next

    With ThisWorkbook.Worksheets("Sheet3")
        Application.ScreenUpdating = False
        .Cells.Clear
        .Range("A1").Resize(, 4) = Array("ID", "Date", "Days", "Sheet")
        .Range("A2").Resize(UBound(arr2), 4) = arr2
        .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

It is quite difficult to generate realistic data so I am not able to optimise things correctly. I have only the small amount of data you supplied.
 
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

motherindia said:
Hello Sir,

I have 2 sheets in workbook which I need to compare. I need to identify missing highlight in color and provide the un matching date .


Eno 01-Sep-14 02-Sep-14 03-Sep-14 04-Sep-14 05-Sep-14 06-Sep-14 07-Sep-14 08-Sep-14 09-Sep-14 10-Sep-14 11-Sep-14 12-Sep-14 13-Sep-14 14-Sep-14 15-Sep-14 16-Sep-14 17-Sep-14 18-Sep-14 19-Sep-14 20-Sep-14 21-Sep-14 22-Sep-14 23-Sep-14 24-Sep-14 25-Sep-14 26-Sep-14 27-Sep-14 28-Sep-14 29-Sep-14 30-Sep-14
1 HS OS OS OS WO WO HS 10.15 10.15 OS HS OS WO HS HS HS HL HS WO WO HS HS HS HS HL WO WO HS HS EL 01-09-15 23-09-15




Sheet2

Emp no Type from date to date
1 OS 01-03-14 04-Sep-14
1 OS 10-09-14 11-09-14
1 HL 17-09-14 21-09-14



Result
E# Type Daysmissing
1 OS 10-09-2014,12-09-14
1 HL 25-Sep-14

I need it for all different type of leave (OS,HL etc...)

I need it to highlight the same Sheet1 against above date with color.


I need to compare Empno, Type whether it is matching in Sheet2 . If not highlight in Color and update the missing date in separate sheet.

Regards,
Motherindia
Click to expand...


Is that the same question or a new one?

If new, please create a new thread or it will get confusing. Well, even more confusing than it already is. :)

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

I got error at

Set dic = New Dictionary 'CreateObject("Scripting.Dictionary")
 
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

Hi Rick,

your code very fast and I changed Dic as object and Set dic = CreateObject("Scripting.Dictionary") etc.
I got the reason for Runtime error 1004.
The reason is bcoz excel has limit of 1048576 rows that can be copied, since the output of macro is more than 10 lakh rows it will stop. Is it possible combine final output based on consecutive date ranges along with days instead of individual days.

this may resolve my thread.

regards,
motherindia
 
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

motherindia said:
I changed Dic as object and Set dic = CreateObject("Scripting.Dictionary") etc.
I got the reason for Runtime error 1004.
Click to expand...


Sorry, I was experimenting.
Code: 
    Dim dic  As Dictionary
    Set dic = New Dictionary
should run slightly faster than:
Code: 
    Dim dic  As Object
    Set dic = CreateObject("Scripting.Dictionary")
Unfortunately, I don't have enough data to see much of a difference. It does shave off about 10-20% but as that is only 2 milliseconds it is not very conclusive.

Note: To make the first one work you need to go into Tools-->References and select Microsoft Scripting Runtime.
It is faster because Excel can make some connections at compile time if it knows all the details of the object - a Dictionary in this case. Otherwise, it has to find out the details each time it is used when the code is running.

I will need to think about the more than 1048576 rows issue. I think you might have to write to Bill Gates and ask him to make Excel bigger. :)

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

This code puts the results from the two sheets into separate columns. That may be enough to overcome the 1048576 Excel limit.

I am slightly concerned because that means that you have over a million discrepancies between the two files. That is an awful lot of issues.

Code: 
Sub Test7()
    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

    Set dic1 = CreateObject("Scripting.Dictionary")
    Set dic2 = 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
            dic1(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 dic1.exists(key) Then
                dic1.Remove key
            Else
                dic2(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(dic1.Count, 4) = Application.Index(dic1.Items, 0, 0)
        .Columns("B").NumberFormat = "DD-MMM-YY"
        .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 4).Sort _
            key1:=.Range("A1"), key2:=.Range("B1"), Header:=xlYes
            
        .Range("F1").Resize(, 4) = Array("ID", "Date", "Days", "Sheet")
        .Range("F2").Resize(dic2.Count, 4) = Application.Index(dic2.Items, 0, 0)
        .Columns("G").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

Regards,
 
Last edited:
Upvote 0
Re: Scripting Dictionay vba for matching start date and end date range between 2 sheets for each id

RickXL said:
Code: 
    Dim dic  As Dictionary
    Set dic = New Dictionary
Click to expand...
Just the one line
Code: 
Dim dic As New Dictionary
is quite adequate.

This so-called early binding can give an easily tested and useful speed advantage particularly in large problems over the much more usual
Code: 
Dim dic as object
Set dic=createobject(...
 
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
Formula - Sumif(s)? Sumproduct? etc.
2
Replies
16
Views
278
Fluff
Fluff
A
  • Solved
Lookup PAAF ID based on Worker ID and date range
Replies
3
Views
123
Fluff
Fluff
K
  • Question Question
Index+Match
Replies
4
Views
302
etaf
etaf
ExcelNewbie2020
  • Solved
transpose data
2
Replies
15
Views
588
kvsrinivasamurthy
K
ricafonyat
  • Solved
Valid Prices
Replies
1
Views
86
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,912
Messages
6,175,340
Members
452,638
Latest member
Oluwabukunmi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top