Chỉ giúp em code vba tạo lịch cả năm được hỏi, với mỗi tháng có hàng tiêu đề thứ mấy (1 người xem)

[Lequocvan]

Em biết có những mẫu lịch sẵn của excel, của outlook rồi nhưng vì mò mẫm tìm hiểu nên em muốn các thầy, ace giúp em đoạn code tạo ra lịch của cả năm được hỏi ( gồm 12 tháng), và sắp xếp các ngày trong tháng theo thứ tự của tuần (2-cn). Nôm na giống cái lịch 12 tháng một tờ treo tường ngày Tết ấy. Em hỏi kỳ cục mong được lượng thứ ah!

 

[ChanhTQ@]

Bạn tham khảo lịch này (tháng giêng năm nào đó); Sau đó tự fát triển xuống bên dưới 11 tháng còn lại xem sao.

 

[Lequocvan]

Ý của em là với code sau:
Sub CreateCalendar()
'Tao lich nam hien tai
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 = "dd" '"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

nhưng chưa tạo được dòng tuần (thứ 2, 3, 4, 5, 6, 7, cn)?

 

[giaiphap]

Ý của em là với code sau:
Sub CreateCalendar()
.................
End Sub

nhưng chưa tạo được dòng tuần (thứ 2, 3, 4, 5, 6, 7, cn)?

Vậy thay code trên thành thế này thử xem.

Sub CreateCalendar()
'Tao lich nam hien tai
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
Dim i As Integer




'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("A16")
Case 4
strMonth = "October"
Set rStart = Range("A24")
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, "A3:G8", "H3:N8", "O3:U8", _
"A10:G14", "H10:N14", "O10:U14", _
"A18:G22", "H18:N22", "O18:U22", _
"A26:G30", "H26:N30", "O26:U30")
lDays = 0
Range(strAddress).BorderAround LineStyle:=xlContinuous
'Add dates to month range and format
Cells(Range(strAddress).Row - 1, Range(strAddress).Column).Resize(, 7).Font.Bold = True
Cells(Range(strAddress).Row - 1, Range(strAddress).Column).Resize(, 7).HorizontalAlignment = xlRight 'xlCenter
For i = 2 To 8
    If i = 8 Then
        Cells(Range(strAddress).Row - 1, Range(strAddress).Column + i - 2) = "Ch" & ChrW(7911) & " nh" & ChrW(7853) & "t"
    Else
        Cells(Range(strAddress).Row - 1, Range(strAddress).Column + i - 2) = "Th" & ChrW(7913) & " " & i
    End If
Next i
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 = "dd" '"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

Nhưng tôi thấy hình như ngày chưa ổn thì phải, bạn nên tham khảo cái này sẽ hay hơn nhiều nè.
http://www.globaliconnect.com/excel...n-excel-vba-free-download&catid=79&Itemid=475