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,611
Được thích
16,671
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

hongquan93vn
Giữ được Hide dòng khi dùng "clear" trong phần học
Trả lời
4
Đọc
81
ngocmaipretty
ngocmaipretty
K
Set macro là disable nhưng file macro vẫn chạy !
Trả lời
3
Đọc
48
kietbui
K
C
  • Question
Tạo schedule chạy code VBA
Trả lời
5
Đọc
206
castanea
C
Emyeuexcel
  • Question
VBA lưu file, in, và mở lại file gốc ban đầu
2
Trả lời
25
Đọc
435
Hoàng Tuấn 868
H
phammaihuong90
Hàm tìm ngày gần nhất đạt được số lượng mục tiêu
Trả lời
10
Đọc
265
phammaihuong90
phammaihuong90
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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