Create a 12 Month Calendar With The Current Day

[Yasser Fathi Albanna]

كود يوضع فى حدث شيت 1 لإنشاء نتيجة العام الحالى والوقوف على اليوم الحالى مظلل

Sub CreateCalendar()

Dim lMonth As Long

Dim strMonth As String

Dim rStart As Range

Dim strAddress As String

Dim rCell As Range

Dim lDays As Long

Dim dDate As Date

'Add new sheet and format

Worksheets.Add

ActiveWindow.DisplayGridlines = False

With Cells

.ColumnWidth = 6#

.Font.Size = 8

End With



'Create the Month headings

For lMonth = 1 To 4

Select Case lMonth

Case 1

strMonth = "January"

Set rStart = Range("A1")

Case 2

strMonth = "April"

Set rStart = Range("A8")

Case 3

strMonth = "July"

Set rStart = Range("A15")

Case 4

strMonth = "October"

Set rStart = Range("A22")

End Select

'Merge, AutoFill and align months

With rStart

.Value = strMonth

.HorizontalAlignment = xlCenter

.Interior.ColorIndex = 6

.Font.Bold = True

With .Range("A1:G1")

.Merge

.BorderAround LineStyle:=xlContinuous

End With

.Range("A1:G1").AutoFill Destination:=.Range("A1:U1")

End With

Next lMonth

'Pass ranges for months

For lMonth = 1 To 12

strAddress = Choose(lMonth, "A2:G7", "H2:N7", "O2:U7", _
"A9:G14", "H9:N14", "O9:U14", _
"A16:G21", "H16:N21", "O16:U21", _
"A23:G28", "H23:N28", "O23:U28")

lDays = 0

Range(strAddress).BorderAround LineStyle:=xlContinuous

'Add dates to month range and format

For Each rCell In Range(strAddress)

lDays = lDays + 1

dDate = DateSerial(Year(Date), lMonth, lDays)

If Month(dDate) = lMonth Then ' It's a valid date

With rCell

.Value = dDate

.NumberFormat = "ddd dd"

End With

End If

Next rCell

Next lMonth

'add con formatting

With Range("A1:U28")

.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=TODAY()"

.FormatConditions(1).Font.ColorIndex = 2

.FormatConditions(1).Interior.ColorIndex = 1

End With

End Sub

 

Create a 12 Month Calendar With The Current Day.rar

[ياسر خليل أبو البراء]

الأخ الحبيب ياسر فتحي راجع الرابط التالي

http://www.officena.net/ib/index.php?showtopic=56629&hl=

 

عله يكون موضوع مكرر ...

أخيراً لقيت حاجة قديمة في الفهرس بتاعي مفيدة !!!

[Yasser Fathi Albanna]

الأخ الحبيب ياسر فتحي راجع الرابط التالي

http://www.officena.net/ib/index.php?showtopic=56629&hl=

 

عله يكون موضوع مكرر ...

أخيراً لقيت حاجة قديمة في الفهرس بتاعي مفيدة !!!

أستاذ ياسر

كل أعمالك رائعة ومفيدة جدا جدا

لا حرمن الله من أعمالك

[ياسر خليل أبو البراء]

مشكور أخي الكريم ياسر على دعائك الطيب

وبعدين دي مناغشة بس عشان أصحي الموضوع الخاص بي (عشان بقاله كتير نايم ..!!) فموضوعك صحى موضوعي من النوم

تقبل ودي واحترامي وتحياتي

[خزاني]

بارك الله فيك الأخ الحبيب ياسر فتحي

[Yasser Fathi Albanna]

بارك الله فيك الأخ الحبيب ياسر فتحي

شكرا لك أخى الكريم خزانى على مرورك الطيب جزاك الله كل الخير