ahmedkamalali

Create a 12 Month Calendar With The Current Day


Highlighted in Excel

لانشاء نتيجه السنه مع تظليل تاريخ اليوم باستخدام الميكرو فى الاكسل :

1 نقوم بفتح ملف اكسيل جديد
2 نقوم بالضغط على alte+f11
3 سوف تفتح نافذه الفيجوال بيسك
4 نقوم بالضغط على Sheet1 فى الجهه اليسرى من نافذم الفيجوال بيسك
5 نقوم بنسخ الكود التالى وبعد ذلك نقوم بلصقه فى النافذه المفتوحه امام ال Sheet1

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


6 ستم انشاء Sheet جديد يحتوى على نتيجه السنه



وكل سنه وانتم طيبن

__________________