ادراج رزنامة شهرية لسنة معينة و شهر معين (باختيارك) بدون يوم او يومين تحددهما بنفسك
و اذا لم تحدد الايام (بمسح الخلايا المناسبة) يتم ادراج كامل الشهر
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