[COLOR=Navy]Sub[/COLOR] MG09Nov48
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] mD [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] cD [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] k [COLOR=Navy]As[/COLOR] Variant, p [COLOR=Navy]As[/COLOR] Variant, oMax [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Ray [COLOR=Navy]As[/COLOR] Variant, nDt [COLOR=Navy]As[/COLOR] Date, R [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Dim[/COLOR] Yr [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] mth [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] mDay [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] Ac [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Col [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer[/COLOR]
[COLOR=Navy]Dim[/COLOR] mDif [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Lst [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] LRw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Fdt [COLOR=Navy]As[/COLOR] Date, Dic [COLOR=Navy]As[/COLOR] Object, oSet [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] rRw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] cAc [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] mMax [COLOR=Navy]As[/COLOR] [COLOR=Navy]Integer,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
oSet = 0
[COLOR=Navy]Set[/COLOR] Rng = ActiveSheet.UsedRange
[COLOR=Navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
[COLOR=Navy]If[/COLOR] IsDate(Dn.Value) [COLOR=Navy]Then[/COLOR]
[COLOR=Navy]If[/COLOR] Not Dic.exists(Month(Dn.Value) & "_" & Year(Dn.Value)) [COLOR=Navy]Then[/COLOR]
[COLOR=Navy]Set[/COLOR] Dic(Month(Dn.Value) & "_" & Year(Dn.Value)) = CreateObject("Scripting.Dictionary")
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]If[/COLOR] Not Dic(Month(Dn.Value) & "_" & Year(Dn.Value)).exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
Dic(Month(Dn.Value) & "_" & Year(Dn.Value)).Add Dn.Value, Dn
[COLOR=Navy]Else[/COLOR]
[COLOR=Navy]Set[/COLOR] Dic(Month(Dn.Value) & "_" & Year(Dn.Value)).Item(Dn.Value) = _
Union(Dic(Month(Dn.Value) & "_" & Year(Dn.Value)).Item(Dn.Value), Dn)
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Dn
[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)
oMax = Application.Max(Dic(k).Item(p).Count, oMax)
[COLOR=Navy]Next[/COLOR] p
Fdt = DateSerial(Split(k, "_")(1), Split(k, "_")(0), "1")
ReDim Ray(1 To 6 * oMax * 2 + 2, 1 To 21)
Ray(1, 1) = Format(Fdt, "mmm-yyyy")
[COLOR=Navy]For[/COLOR] mDay = 1 To 7
mD = 1 + (3 * (mDay - 1))
Ray(2, mD) = WeekdayName(mDay, False, 1)
[COLOR=Navy]Next[/COLOR] mDay
Col = 8: Rw = 3
[COLOR=Navy]Select[/COLOR] [COLOR=Navy]Case[/COLOR] Month(Fdt)
[COLOR=Navy]Case[/COLOR] 2: mMax = IIf(Year(Fdt) Mod 4 = 0, 29, 28)
[COLOR=Navy]Case[/COLOR] 4, 6, 9, 11: mMax = 30
[COLOR=Navy]Case[/COLOR] Else: mMax = 31
[COLOR=Navy]End[/COLOR] Select
[COLOR=Navy]For[/COLOR] mDay = 1 To 31
Col = Weekday(DateSerial(Year(Fdt), Month(Fdt), mDay))
cD = 1 + (3 * (Col - 1))
Ray(Rw, cD) = mDay
Rw = Rw + IIf(Col Mod 7 = 0, oMax * 2 + 1, 0)
[COLOR=Navy]If[/COLOR] mDay = mMax [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Exit[/COLOR] For
[COLOR=Navy]Next[/COLOR] mDay
[COLOR=Navy]For[/COLOR] Rw = 1 To UBound(Ray, 1)
[COLOR=Navy]For[/COLOR] Ac = 1 To UBound(Ray, 2)
[COLOR=Navy]If[/COLOR] IsNumeric(Ray(Rw, Ac)) And Not IsEmpty(Ray(Rw, Ac)) [COLOR=Navy]Then[/COLOR]
nDt = DateSerial(Split(k, "_")(1), Split(k, "_")(0), Ray(Rw, Ac))
[COLOR=Navy]If[/COLOR] Dic(k).exists(DateSerial(Split(k, "_")(1), Split(k, "_")(0), Ray(Rw, Ac))) [COLOR=Navy]Then[/COLOR]
c = 1
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] R [COLOR=Navy]In[/COLOR] Dic(k).Item(nDt)
Ray(Rw + c, Ac) = R.Offset(1)
Ray(Rw + c, Ac + 1) = R.Offset(1, 1)
Ray(Rw + c, Ac + 2) = R.Offset(1, 2)
Ray(Rw + c + 1, Ac) = R.Offset(2)
Ray(Rw + c + 1, Ac + 1) = R.Offset(2, 1)
Ray(Rw + c + 1, Ac + 2) = R.Offset(2, 2)
c = c + 2
[COLOR=Navy]Next[/COLOR] R
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Ac
[COLOR=Navy]Next[/COLOR] Rw
[COLOR=Navy]With[/COLOR] Sheets("Sheet2").Range("A1").Offset(oSet).Resize(6 * oMax * 2 + 2, 21)
.Value = Ray
.ColumnWidth = 10 '[COLOR=Green][B]AutoFit[/B][/COLOR]
.Columns.AutoFit
.Borders.Weight = 2
.Font.Bold = True
[COLOR=Navy]End[/COLOR] With
oSet = oSet + 6 * oMax * 2 + 2
[COLOR=Navy]Next[/COLOR] k
'[COLOR=Green][B]#######[/B][/COLOR]
'[COLOR=Green][B]Remove The code below if colours not required[/B][/COLOR]
[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
[COLOR=Navy]If[/COLOR] Dn.Value = "Sunday" [COLOR=Navy]Then[/COLOR]
c = 0
Dn.Resize(, 21).Interior.Color = vbGreen
[COLOR=Navy]Else[/COLOR]
[COLOR=Navy]If[/COLOR] c = 0 Or c Mod 7 = 0 [COLOR=Navy]Then[/COLOR]
Dn.Resize(, 21).Interior.Color = vbYellow
[COLOR=Navy]End[/COLOR] If
c = c + 1
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Dn
'[COLOR=Green][B]#######[/B][/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
