Tặng tiện ích CALENDAR tuyệt đẹp!

Liên hệ QC
Hoàng Trọng Nghĩa

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,662
Được thích
16,718
Giới tính
Nam
***************************************************************************************************************
***************************************************************************************************************
Đã có phiên bản mới tại đây:

Tặng tiện ích CALENDAR (Excel 2007 trở về sau)​


***************************************************************************************************************
***************************************************************************************************************



Nhân dịp khoác trên vai “4 sao vàng”, tôi xin tặng các bạn một UserForm Calendar tuyệt đẹp, nó không những thay thế được với Control Calendar của Excel mà nó còn hiển thị ngày Âm lịch.

(Giới thiệu trước, gửi file ở bài sau)
3.jpg​

Mặc dù mã nguồn tôi đã sưu tầm từ nhiều nơi (thật sự tôi không nhớ nguồn gốc của các mã này của ai sáng tác), nhưng tôi đã cải tiến cũng như thiết kế lại giao diện, kết hợp mã nguồn của dương lịch và mã nguồn chuyển Âm lịch, có đầy đủ “thiên can địa chi” cho năm.

Cũng như tại bài viết này tôi đã giới thiệu (http://www.giaiphapexcel.com/forum/showthread.php?36542-Đặt-caption-cho-nhiều-Label&p=242247#post242247) thì cải tiến lần này hoàn chỉnh nhất, Calendar này sẽ nhớ ngày hiện hành (hôm nay) bằng cách tô màu hồng đậm. Dùng phím mũi tên (lên, xuống, trái, phải) để di chuyển giữa các ô ngày; mỗi ô ngày được chọn sẽ có nền trắng, viền ngoài để phân biệt với ngày hiện hành và các ngày trong tháng.

Các bạn để ý sẽ thấy, khi ô ngày nào được chọn, thì Label ở dưới cùng thể hiện ngày Dương lịch được chọn bên trái và ngày Âm lịch được chọn bên phải, chúng có màu nền, cũng như màu font chữ của ô ngày hiện hành.

Cũng tại Label này, khi bạn đang chọn ngày khác với ngày hiện hành, thì bạn click vào đó nó sẽ chọn về ngày hôm nay.

2.jpg​

Nếu bạn rê chuột ngang qua nó, nó sẽ show cho bạn một ToolTip để báo bạn biết chức năng của nó.

Đặc biệt, lần cải tiến này tôi đã thay đổi 2 Label tháng và năm thành 2 ComboBox THÁNG & NĂM để chúng ta có thể di chuyển ngay tới tháng hoặc năm cần xem.

1.jpg

– Chọn tháng –

4.jpg

– Chọn năm –

5.jpg
​

Các thao tác trên lịch:

  • Di chuyển giữa các ô ngày bằng các phím mũi tên để di chuyển qua lại, lên xuống.
  • Dùng phím Tab để di chuyển ngày kế tiếp, shift + tab để di chuyển ngược lại.
  • PgUp, PgDn để chọn tháng trước, tháng sau (tương đương với bấm vào 2 CommandButton mũi tên qua, lại sát ComboBox Tháng, cũng tương đương Shift + các phím mũi tên).
  • Shift+ PgUp/ PgDn để chọn năm trước, năm sau (tương đương với bấm vào 2 CommandButton mũi tên qua, lại sát ComboBox Năm).
  • Phím Home để trở về ngày hiện hành (ngày hôm nay).

Các bạn cứ bấm thử với Shift hoặc Ctrl kết hợp với các phím trên sẽ nắm rõ nguyên lý hoạt động của lịch.

Với phím Enter, Esc hoặc click vào ô ngày nào đó sẽ thoát lịch.

Nếu lịch được khởi động trên một UserForm và muốn nhận giá trị ngày từ Calendar vào một TextBox trên form này, thì sau khi thoát Lịch, giá trị lịch tại ô ngày nào được chọn sẽ nhập vào TextBox của UserForm đó.

Năm nào có tháng nhuần thì nó thể hiện chữ (N) trên Calendar.

6.jpg​
Khi gọi Calendar từ một UserForm, nếu TextBox cần nhập Date có sẳn ngày tháng, lịch sẽ lấy ngày đó làm ngày hiển thị, ngược lại, lịch sẽ hiển thị ngày hiện hành.

7.jpg
​
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
huuthang_bd đã viết:
Lỡ làm thì làm nốt trường hợp này luôn đi --=0
View attachment 147250
Nhấp chuột vào đây để mở rộng...

ngạc nhiên chưa ? há há --=0--=0

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
            arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
            arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
            Exit For
        End If
    Next
End With
CellPositionB = arr
End Function
 
Upvote 0
doveandrose đã viết:
ngạc nhiên chưa ? há há --=0--=0

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
            arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
            arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
            Exit For
        End If
    Next
End With
CellPositionB = arr
End Function
Nhấp chuột vào đây để mở rộng...
Ui trời ơi, thật là tuyệt đó nha! Quá tốt rồi, không chê vào đâu được! Đã thử thường, Zoom và các loại Panes. Code quá ngắn luôn!
 
Upvote 0
À, dùng trong Hàm chớ bao giờ dùng Offset nhé, sẽ phát sinh ra lỗi nếu chọn hàng hay cột cuối cùng.

rCell.Offset(1).Top


Chỉ nên cộng thêm vào phút 89 của trận đấu thôi! -\\/.
 
Upvote 0
doveandrose đã viết:
ngạc nhiên chưa ? há há --=0--=0

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
            arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
            arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
            Exit For
        End If
    Next
End With
CellPositionB = arr
End Function
Nhấp chuột vào đây để mở rộng...
Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell
 
Upvote 0
huuthang_bd đã viết:
Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell
Nhấp chuột vào đây để mở rộng...

Đã thử trên nhiều trường hợp rồi Thắng ơi, Hàm chạy OK trong 3 trường hợp của panes, 4 phần pane đặt con trỏ ở vùng nào cũng chạy chuẩn.
Với trường hợp ô được chọn khuất trong pane ta nên active ô đó rồi chạy hàm. Như thế trong hàm cần thêm câu lệnh:

Set rCell=rCell(1, 1) phòng trường hợp rCell là selection

Sau đó là rCell.Activate

Rồi mới đến With ActiveWindow.

(Cũng đang trên đt, nhưng đã test tối qua).
 
Upvote 0
doveandrose đã viết:
ủa click vào đó thì nó tự active cell đối xứng bên tay trái => active cell nằm bên tay trái mà . có gì ngạc nhiên
Nhấp chuột vào đây để mở rộng...

Thật ra nó tính không sai, nhưng đang thao tác trên vùng này mà nó chạy form bên vùng khác khi 2 vùng cùng hiển thị activecell thì hơi khó chịu đó mà.
 
Upvote 0
doveandrose đã viết:
ủa click vào đó thì nó tự active cell đối xứng bên tay trái => active cell nằm bên tay trái mà . có gì ngạc nhiên
Nhấp chuột vào đây để mở rộng...
Thì đúng vẫn là cell đó nhưng hổng lẽ nhập liệu phải như vầy
[video=youtube;3nL-tHkKkyA]https://www.youtube.com/watch?v=3nL-tHkKkyA&feature=youtu.be[/video]
 
Upvote 0
Nên chăng sửa lại như vầy
PHP: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionC = arr
End Function
 
Upvote 0
huuthang_bd đã viết:
Nên chăng sửa lại như vầy
PHP: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionC = arr
End Function
Nhấp chuột vào đây để mở rộng...
OK, vậy là ổn rồi! Đã test!-=.,,
 
Upvote 0
huuthang_bd đã viết:
Nên chăng sửa lại như vầy
PHP: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionC = arr
End Function
Nhấp chuột vào đây để mở rộng...

hi hi

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing And [COLOR=#ff0000][B]False[/B][/COLOR] Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionB = arr
End Function
 
Upvote 0
huuthang_bd đã viết:
Nên chăng sửa lại như vầy
PHP: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionC = arr
End Function
Nhấp chuột vào đây để mở rộng...
Tôi nghĩ là nên như vầy:

Mã: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
    Dim arrLeftTop(1 To 2) As Double, r As Byte
[B][COLOR=#ff0000]    Set rCell = rCell(1, 1): rCell.Activate[/COLOR][/B]
    With ActiveWindow
        If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
            For r = 1 To .Panes.Count
                If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                    arrLeftTop(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                    arrLeftTop(2) = .Panes(r).PointsToScreenPixelsY(rCell.Top) * 0.75 [COLOR=#ff0000][B]+ rCell.Height[/B][/COLOR]
                    Exit For
                End If
            Next
        Else
            arrLeftTop(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
            arrLeftTop(2) = .ActivePane.PointsToScreenPixelsY(rCell.Top) * 0.75 [COLOR=#ff0000][B]+ rCell.Height[/B][/COLOR]
        End If
    End With
    CellPositionC = arrLeftTop
End Function
 
Upvote 0
doveandrose đã viết:
hi hi

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing And [COLOR=#ff0000][B]False[/B][/COLOR] Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionB = arr
End Function
Nhấp chuột vào đây để mở rộng...
Lý do gì thêm False vậy? Trường hợp nào phát sinh False?
 
Upvote 0
doveandrose đã viết:
hi hi

Mã: 
Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing And [COLOR=#ff0000][B]False[/B][/COLOR] Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionB = arr
End Function
Nhấp chuột vào đây để mở rộng...
Bạn thử với 1 ô thuộc Panes(1) khi đang Freeze Panes xem có đúng không.
@Hoàng Trọng Nghĩa: Ý là bỏ luôn đoạn đó đó.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
16
Đọc
19K
qthinh4996
Q
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
2
Đọc
108
ptm0412
ptm0412
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
Trả lời
7
Đọc
196
huuthang_bd
huuthang_bd
N
Giúp sửa mã code
Trả lời
16
Đọc
238
ptm0412
ptm0412
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
0
Đọc
21
dung09031989
dung09031989
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
1
Đọc
29
tranvansau278
T
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
0
Đọc
30
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
1
Đọc
24
hoangminhtien
hoangminhtien
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
244
Đọc
13K
HeSanbi
HeSanbi
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
2
Đọc
67
phutdm
P
dunghtgiga
  • Đã khóa
Tính bốn tuần cho một tháng
Trả lời
9
Đọc
259
ptm0412
ptm0412
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
3
Đọc
96
HUONGHCKT
H
Mr Đạo
in giấy ra bị lệch xuống dưới
    • Thích
2
Trả lời
29
Đọc
26K
Hoàng Tuấn 868
H
H
Không xem được ảnh trên Excel
Trả lời
3
Đọc
1K
huyentran9292
H
T
Xin form quản lý dữ liệu học viên của Trung tâm Đào tạo
Trả lời
2
Đọc
211
hakiru188
H
C
Code Lọc Dữ Liệu
Trả lời
10
Đọc
168
Cúc Hr
C
Y
Cách ẩn công thức 1 ô trong sheet
Trả lời
8
Đọc
114
hoangminhtien
hoangminhtien
vuha
  • Question
Lỗi chọn dòng thứ 6 trong sheet được chọn: rows("6:6").select
Trả lời
12
Đọc
157
ptm0412
ptm0412
Nguyencaocuong86
Tô màu dữ liệu trùng lặp trong excel.
Trả lời
10
Đọc
140
Nguyencaocuong86
Nguyencaocuong86
Hoangquyenbong
  • Question
Nhờ viết code lọc dữ liệu tại các sheet khác nhau.
Trả lời
12
Đọc
162
Hoangquyenbong
Hoangquyenbong
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom