Calendar رزنامة بدون يومين تحددهما بنفسك

[سليم حاصبيا]

ادراج رزنامة شهرية لسنة معينة و شهر معين (باختيارك) بدون يوم او يومين تحددهما بنفسك

و اذا لم تحدد الايام (بمسح الخلايا المناسبة) يتم ادراج كامل الشهر

 

Sub Give_date_without_same_days()
  With CommandButton1
   .Left = 469: .Top = 18.5: .Width = 154.5
  End With
 If Not IsNumeric([a2]) Or Not IsNumeric([b2]) _
  Or [b2] < 1 Or [b2] > 12 _
  Or IsEmpty([a2]) Or IsEmpty([b2]) Then
   MsgBox "أدخل أرقاماً صحيحة في الخلايا " & Chr(10) & "$ِِِA$2 and $B$2 " & Chr(10) _
   & "وأعد المحاولة", vbOKOnly + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "!...ٍSalim"
  Range("c4:Ag5").ClearContents
  Range("c4:Ag5").Borders.LineStyle = 0
 GoTo Exit_Me
  End If
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .Calculation = xlManual
    End With
Dim Array_Days(), My_Days_Arabic()
Dim Arab_Day(), My_Date_For_Print()
Dim Array_Numbers()
Dim t As Date, i%, k%, m%, x%, last_col%
Dim y$
'==============================
  Array_Days = Array("sun", "mon", "tue", "wed", "thu", "fri", "sat")
  Arab_Day = Array("الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السّبت")
  Array_Numbers = Array(1, 2, 3, 4, 5, 6, 7)
  last_col = Cells(5, Columns.Count).End(1).Column
  Range("c4").Resize(2, last_col).ClearContents
  Range("c4").Resize(2, last_col).Borders.LineStyle = 0
'=================================
  [a2] = Int([a2]): [b2] = Int([b2])
  t = DateSerial([a2], [b2], 1)
  x = Day(Application.EoMonth(t, 0))
  k = 1
  For i = 1 To x
     y = Application.Index(Arab_Day, Application.Match(Weekday(t), Array_Numbers, 0))
     If Trim(y) = Trim([d2].Value) Or _
     Trim(y) = Trim([e2].Value) Then GoTo 2
    ReDim Preserve My_Days_Arabic(1 To k): My_Days_Arabic(k) = y
  ReDim Preserve My_Date_For_Print(1 To k): My_Date_For_Print(k) = t
  k = k + 1
'  End If
2:
 t = t + 1
Next
 
    Range("C4").Resize(1, UBound(My_Days_Arabic)) = My_Days_Arabic
    Range("C5").Resize(1, UBound(My_Date_For_Print)) = My_Date_For_Print
    Range("C4").Resize(2, UBound(My_Days_Arabic)).Borders.LineStyle = 1
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = Range("a1").Resize(6, UBound(My_Days_Arabic) + 2).Address
Exit_Me:
Erase Array_Days: Erase Arab_Day: Erase Array_Numbers
  With Application
   .ScreenUpdating = True
   .Calculation = xlAutomatic
   .EnableEvents = True
  End With

End Sub

Private Sub CommandButton1_Click()
Give_date_without_same_days
End Sub

Private Sub Worksheet_Activate()
  With CommandButton1
   .Left = 469: .Top = 18.5: .Width = 154.5
  End With
End Sub

الكود موجود ضمن الملف

Date_sans_deux_jours.xlsm

[Ali Mohamed Ali]

بارك الله فيك ربنا يزيدك من علمه-فكرة جميلة جداً ومطلوبة فى عمليات كتير

ربنا يوفقك ودائما إلى الأمام أستاذنا العزيز