এক্সেলে সেলে তারিখ যোগ করতে ডাবল ক্লিক করুন-Double click to add date to cell in excel

 

ওয়ার্কশীটের যেকোনো cell-এ ডাবল ক্লিক করে "ক্যালেন্ডার ইউজারফর্ম" এর মাধ্যমে তারিখ যোগ এবং পরিবর্তন করতে পারবেন। ওয়ার্কশীটের যেকোনো  cell-এ  তারিখ যোগ এবং পরিবর্তন করার জন্য আমরা একটি ছোট  ইউজারফর্ম তৈরি করেছি। আমাদের ইউজারফর্ম হল ডেট পিকারের একটি দরকারী বিকল্প যার কোনো .ocx ফাইলের প্রয়োজন নেই৷ যখন নির্বাচিত কলামের সেলগুলিতে ডাবল-ক্লিক করার মাধ্যমে, ইউজারফর্ম খোলে   বছর, মাস এবং দিনের জন্য তৈরি করা যে বাটন উপর ক্লিক করলে, তখন তারিখটি  সেলে যোগ হয়ে যাবে। 

ওয়ার্কশীটের যেকোনো cell-এ ডাবল ক্লিক করলে ক্যালেন্ডার ইউজারফর্ম প্রদর্শিত করতে কোড: 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Call DisplayUserForm
End Sub

একটি ইউজারফর্ম বানান: 

মাসের নামগুলি এবং বছরের ড্রপ-ডাউন তালিকায় তালিকাভুক্ত করা হয়েছে যা ইউজারফর্ম ক্যাপশনে মাস থেকে শুরু করে (আজকের তারিখ)।

ক্যালেন্ডার ফর্মের Create_Calendar পদ্ধতিতে কিছু পরিবর্তন করে, সেলে প্রবেশ করা তারিখের বিন্যাস পরিবর্তন করা যেতে পারে, ইউজারফর্ম  নিচের কোড ব্যবহার করুন

 : 

'For more : https://karimexcelvba.blogspot.com/

Option Explicit
    Dim ThisDay As Date
    Dim ThisYear, ThisMth As Date
    Dim CreateCal As Boolean
    Dim i As Integer

Private Sub CB_Mth_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.CB_Mth.DropDown
End Sub

Private Sub CB_Yr_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Me.CB_Yr.DropDown
End Sub
Private Sub Userform_Activate()
Call SystemButtonSettings(Me, False)
End Sub
Private Sub UserForm_Initialize()
Call SystemButtonSettings(Me, False)
    Application.EnableEvents = False
    'starts the form on todays date
    ThisDay = Date
    ThisMth = VBA.Format(ThisDay, "mm")
    ThisYear = VBA.Format(ThisDay, "yyyy")
    For i = 1 To 12
        CB_Mth.AddItem VBA.Format(DateSerial(Year(Date), Month(Date) + i, 0), "mmmm")
    Next
    CB_Mth.ListIndex = VBA.Format(Date, "mm") - VBA.Format(Date, "mm")
    For i = -20 To 50
        If i = 1 Then CB_Yr.AddItem VBA.Format((ThisDay), "yyyy") Else CB_Yr.AddItem _
            VBA.Format((DateAdd("yyyy", (i - 1), ThisDay)), "yyyy")
    Next
    CB_Yr.ListIndex = 21
    'Builds the calendar with todays date
    CalendarForm.Width = CalendarForm.Width
    CreateCal = True
    Call Create_Calendar
    Application.EnableEvents = True
End Sub
Private Sub CB_Mth_Change()
   Call Create_Calendar
End Sub
Private Sub CB_Yr_Change()
   Call Create_Calendar
End Sub
Private Sub Create_Calendar()
    If CreateCal = True Then
    CalendarForm.Caption = " " & CB_Mth.Value & " " & CB_Yr.Value
    'sets the focus for the todays date button
    CommandButton1.SetFocus
For i = 1 To 42
 If i < Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
 Controls("D" & (i)).Caption = VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" _
 & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
  Controls("D" & (i)).ControlTipText = VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
  & "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mm/dd/yyyy")
   ElseIf i >= Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
   Controls("D" & (i)).Caption = VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
  & "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
 Controls("D" & (i)).ControlTipText = VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
 & "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mm/dd/yyyy")
        End If
        If VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
  ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mmmm") = ((CB_Mth.Value)) Then
         Controls("D" & (i)).Font.Bold = True
                    
    If VBA.Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
 ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mm/dd/yyyy") = VBA.Format(ThisDay, "mm/dd/yyyy") _
 Then Controls("D" & (i)).SetFocus
        Else
Controls("D" & (i)).Font.Bold = False
        End If
    Next
    End If
End Sub
Private Sub D1_Click()
    ActiveCell.Value = D1.ControlTipText
    Unload Me
       
End Sub
Private Sub D2_Click()
    ActiveCell.Value = D2.ControlTipText
    Unload Me
    
End Sub
Private Sub D3_Click()
    ActiveCell.Value = D3.ControlTipText
    Unload Me
    
End Sub
Private Sub D4_Click()
    ActiveCell.Value = D4.ControlTipText
    Unload Me
    
End Sub
Private Sub D5_Click()
    ActiveCell.Value = D5.ControlTipText
    Unload Me
    
End Sub
Private Sub D6_Click()
    ActiveCell.Value = D6.ControlTipText
    Unload Me
    
End Sub
Private Sub D7_Click()
    ActiveCell.Value = D7.ControlTipText
    Unload Me
    
End Sub
Private Sub D8_Click()
    ActiveCell.Value = D8.ControlTipText
    Unload Me
    
End Sub
Private Sub D9_Click()
    ActiveCell.Value = D9.ControlTipText
    Unload Me
    
End Sub
Private Sub D10_Click()
    ActiveCell.Value = D10.ControlTipText
    Unload Me
    
End Sub
Private Sub D11_Click()
    ActiveCell.Value = D11.ControlTipText
    Unload Me
    
End Sub
Private Sub D12_Click()
    ActiveCell.Value = D12.ControlTipText
    Unload Me
    
End Sub
Private Sub D13_Click()
    ActiveCell.Value = D13.ControlTipText
    Unload Me
    
End Sub
Private Sub D14_Click()
    ActiveCell.Value = D14.ControlTipText
    Unload Me
    
End Sub
Private Sub D15_Click()
    ActiveCell.Value = D15.ControlTipText
    Unload Me
    
End Sub
Private Sub D16_Click()
    ActiveCell.Value = D16.ControlTipText
    Unload Me
    
End Sub
Private Sub D17_Click()
    ActiveCell.Value = D17.ControlTipText
    Unload Me
    
End Sub
Private Sub D18_Click()
    ActiveCell.Value = D18.ControlTipText
    Unload Me
    
End Sub
Private Sub D19_Click()
    ActiveCell.Value = D19.ControlTipText
    Unload Me
    
End Sub
Private Sub D20_Click()
    ActiveCell.Value = D20.ControlTipText
    Unload Me
    
End Sub
Private Sub D21_Click()
    ActiveCell.Value = D21.ControlTipText
    Unload Me
    
End Sub
Private Sub D22_Click()
    ActiveCell.Value = D22.ControlTipText
    Unload Me
    
End Sub
Private Sub D23_Click()
    ActiveCell.Value = D23.ControlTipText
    Unload Me
    
End Sub
Private Sub D24_Click()
    ActiveCell.Value = D24.ControlTipText
    Unload Me
    
End Sub
Private Sub D25_Click()
    ActiveCell.Value = D25.ControlTipText
    Unload Me
    
End Sub
Private Sub D26_Click()
    ActiveCell.Value = D26.ControlTipText
    Unload Me
    
End Sub
Private Sub D27_Click()
    ActiveCell.Value = D27.ControlTipText
    Unload Me
    
End Sub
Private Sub D28_Click()
    ActiveCell.Value = D28.ControlTipText
    Unload Me
    
End Sub
Private Sub D29_Click()
    ActiveCell.Value = D29.ControlTipText
    Unload Me
    
End Sub
Private Sub D30_Click()
    ActiveCell.Value = D30.ControlTipText
    Unload Me
    
End Sub
Private Sub D31_Click()
    ActiveCell.Value = D31.ControlTipText
    Unload Me
    
End Sub
Private Sub D32_Click()
    ActiveCell.Value = D32.ControlTipText
    Unload Me
    
End Sub
Private Sub D33_Click()
    ActiveCell.Value = D33.ControlTipText
    Unload Me
    
End Sub
Private Sub D34_Click()
    ActiveCell.Value = D34.ControlTipText
    Unload Me
    
End Sub
Private Sub D35_Click()
    ActiveCell.Value = D35.ControlTipText
    Unload Me
    
End Sub
Private Sub D36_Click()
    ActiveCell.Value = D36.ControlTipText
    Unload Me
    
End Sub
Private Sub D37_Click()
    ActiveCell.Value = D37.ControlTipText
    Unload Me
    
End Sub
Private Sub D38_Click()
    ActiveCell.Value = D38.ControlTipText
    Unload Me
    
End Sub
Private Sub D39_Click()
    ActiveCell.Value = D39.ControlTipText
    Unload Me
    
End Sub
Private Sub D40_Click()
    ActiveCell.Value = D40.ControlTipText
    Unload Me
    
End Sub
Private Sub D41_Click()
    ActiveCell.Value = D41.ControlTipText
    Unload Me
    
End Sub
Private Sub D42_Click()
    ActiveCell.Value = D42.ControlTipText
    Unload Me
    
End Sub

মডিউল ১: 

'For more : https://karimexcelvba.blogspot.com/
Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDc As LongPtr) As Long
    Dim hDc As LongPtr
#Else
    Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) As Long
    Dim hDc As Long
#End If
Sub DisplayUserForm()
    Dim objCell As Range
    Dim objUserForm As Object
    Set objCell = ActiveCell
    Set objUserForm = CalendarForm
    PositionForm objUserForm, objCell
    objUserForm.show
End Sub
Sub PositionForm(ByVal objUserForm As Object, ByVal objPosCell As Range)
    With objUserForm
        .startupposition = 0
        .Left = TopLeftPoint(objPosCell).X + objPosCell.Width
        .Top = TopLeftPoint(objPosCell).Y
    End With
End Sub
Function TopLeftPoint(ByVal Alan As Range) As POINTAPI
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    Const PointsPerInch = 72
    Dim PixelsPerPointX As Double
    Dim PixelsPerPointY As Double
    Dim PointsPerPixelX As Double
    Dim PointsPerPixelY As Double
    hDc = GetDC(0)
    PixelsPerPointX = GetDeviceCaps(hDc, LOGPIXELSX) / PointsPerInch
    PointsPerPixelX = PointsPerInch / GetDeviceCaps(hDc, LOGPIXELSX)
    PixelsPerPointY = GetDeviceCaps(hDc, LOGPIXELSY) / PointsPerInch
    PointsPerPixelY = PointsPerInch / GetDeviceCaps(hDc, LOGPIXELSY)
    With TopLeftPoint
        .X = ActiveWindow.PointsToScreenPixelsX(Alan.Left * _
        (PixelsPerPointX * (ActiveWindow.Zoom / 100))) * PointsPerPixelX
        .Y = ActiveWindow.PointsToScreenPixelsY(Alan.Top * _
        (PixelsPerPointY * (ActiveWindow.Zoom / 100))) * PointsPerPixelY
    End With
    ReleaseDC 0, hDc
End Function