اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

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

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

 

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

  • Like 7
قام بنشر

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

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

  • Like 2

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
×
×
  • اضف...

Important Information