อยากได้ POP Up Date Excel ครับ

[artkitthana]

รบกวนอาจารย์ทุกท่าครับ
ผมลองทำหลายวิธีแล้วไม่ได้
ผมอยากได้ POP Up Date Excel ครับ

[parakorn]

มีหลายวิธีครับ ส่วนตัวเคยเขียน VBA เพื่อแสดง Pop-up calendar เวลา user คลิ๊ก Cell พบว่าเวลาส่งไปให้เครื่องอื่นที่มี Version ต่ำกว่าจะใช้งานไม่ได้ แนะนำให้ลองหา Add-ins ที่ Support หลาย Version หรือ ลองศึกษา VBA ดูครับ
ลองค้น Keyword "add-ins calendar in excel" ใน Google ดูก็ได้ครับ

[artkitthana]

ทำไมไม่แสดง ปฏิทินครับ

Option Explicit

Private WithEvents Calendar1 As cCalendar

Public Target As Range

Private Sub UserForm_Initialize()
If Calendar1 Is Nothing Then
Set Calendar1 = New cCalendar
With Calendar1
.Add_Calendar_into_Frame Me.Frame1
.UseDefaultBackColors = False
.DayLength = 3
.MonthLength = mlENShort
.Height = 140
.Width = 180
.GridFont.Size = 7
.DayFont.Size = 7
.Refresh
End With
Me.Height = 173 'Win7 Aero
Me.Width = 197
End If
End Sub

Public Property Get Calendar() As cCalendar
Set Calendar = Calendar1
End Property

Private Sub UserForm_Activate()

If IsDate(Target.Value) Then
Calendar1.Value = Target.Value
End If

Call MoveToTarget

End Sub

Public Sub MoveToTarget()
Dim dLeft As Double, dTop As Double

dLeft = Target.Left - ActiveWindow.VisibleRange.Left + ActiveWindow.Left
If dLeft > Application.Width - Me.Width Then
dLeft = Application.Width - Me.Width
End If
dLeft = dLeft + Application.Left

dTop = Target.Top - ActiveWindow.VisibleRange.Top + ActiveWindow.Top
If dTop > Application.Height - Me.Height Then
dTop = Application.Height - Me.Height
End If
dTop = dTop + Application.Top

Me.Left = IIf(dLeft > 0, dLeft, 0)
Me.Top = IIf(dTop > 0, dTop, 0)
End Sub

Private Sub Calendar1_Click()
Call CloseDatePicker(True)
End Sub

Private Sub Calendar1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = vbKeyEscape Then
Call CloseDatePicker(False)
End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = 1
CloseDatePicker (False)
End If
End Sub

Sub CloseDatePicker(Save As Boolean)
If Save And Not Target Is Nothing And IsDate(Calendar1.Value) Then
Target.Value = Calendar1.Value
End If
Set Target = Nothing
Me.Hide
End Sub

[parakorn]

Code ที่แนบมาเป็นโค้ดที่ใช้ควบคุม Calendar ที่สร้างขึ้นด้วย User form อีกทีครับ ไม่ใช่นำมาวางแล้วจะเกิดเป็นปฏิทินเลย
และ ไฟล์ที่ Support Code VBA ต้อง Save เป็นนามสกุล .xlsm ครับ

ลองดูเป็น แบบ template Date Picker control ลองศึกษาตามลิ้งค์นี้ครับ
https://www.ablebits.com/office-addins- ... -template/