Chương trình làm lịch

[ThichExcel]

Sub CreateCalendar() 
Dim lMonth As Long, lDays As Long  
Dim strMonth As String,  strAddress As String 
Dim rStart As Range, rCell As Range 
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