[COLOR="Navy"]Sub[/COLOR] MG14Nov57
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Fd [COLOR="Navy"]As[/COLOR] Boolean
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[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"]With[/COLOR] Sheets("Sheet1")
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
[COLOR="Navy"]End[/COLOR] If
oDts = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
[COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(oDts) [COLOR="Navy"]Then[/COLOR]
Dic(Dn.Value).Add (oDts), Array(Dn.Offset(, 3).Value, Rng.Parent.Name)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
[COLOR="Navy"]Set[/COLOR] Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
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] Dn.Value = k And CDate(Dn.Offset(, 1).Value) >= Sp(0) And CDate(Dn.Offset(, 2).Value) <= Sp(1) [COLOR="Navy"]Then[/COLOR]
Q = Dic(k).Item(p)
Q(0) = Q(0) - Dn.Offset(, 3).Value
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 = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
[COLOR="Navy"]If[/COLOR] Fd = False [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]If[/COLOR] Not Dic.exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
[COLOR="Navy"]End[/COLOR] If
oDts = Dn.Offset(, 1).Value & "_" & Dn.Offset(, 2).Value
[COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).exists(oDts) [COLOR="Navy"]Then[/COLOR]
Dic(Dn.Value).Add (oDts), Array(Dn.Offset(, 3).Value, Rng.Parent.Name)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
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
.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)
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] p
[COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]