Monthly Calendar

**سليم حاصبيا** · فبراير 4, 2018

طلب الي احد الاصدقاء وضع كود لادراج رزنامة لسنة محددة وشهر محدد مع تمييز (يوم معيّن) من هذا الشهر

فكان هذا الكود الذي ارجو ان يستفيد منه الاخرون

قبل تنفيذ الكود الكود:

تسمية الصفحة التي تريد العمل عليها بهذا الاسم "Salim_Calendar"

اكتب

في الخلية B1 رقم السنة

في الخلية B2 رقم الشهر

في الخلية G1 رقم اليوم المييز

الكود

Option Explicit
Option Base 1
Sub My_Calandar()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
Dim t As Date, i As Byte
Dim Arab_day(), m%
Dim EnG_day(), rows_count As Byte
Dim col As Byte
Dim r As Byte
Dim search_day As Date

rows_count = Range("b4").CurrentRegion.Rows.Count + 3
Range("b4:H" & rows_count).ClearContents
Range("b5:h10").Interior.ColorIndex = 0

 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
 t = DateSerial([b1], [b2], 1)
 
    '''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    search_day = DateSerial([b1], [b2], [g1])
    
        Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
'    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
   m = Weekday(t) + 1
    For i = 1 To 31
         Cells(r, m) = t
          If t = search_day Then
            Cells(r, m).Interior.ColorIndex = 3
            Else
            Cells(r, m).Interior.ColorIndex = 35
          End If
                If Month(t + 1) > [b2] Then Exit For
              t = t + 1
              m = m + 1
         col = Cells(r, m).Column
          If col > 8 Then r = r + 1: m = 2
    Next
 Erase Arab_day
  
End Sub

الملف مرفق

My_Calendar.xlsm

**أ / محمد صالح** · فبراير 4, 2018

ما شاء الله

إبداع أخي سليم

وخاصة التأكد من قيم الخلايا التي يدخلها المستخدم

وفقنا الله وإياكم لكل ما يحب ويرضى

abo-mu7ammad · فبراير 4, 2018

تسلم الأيادي ... عمل رائع :signthankspin:

اقتباس

اقتباس

**سليم حاصبيا** · فبراير 5, 2018

قليل من التحسين على الكود (ازالة حلقة تكرارية- للتلوين ) و تحديد نهاية الحلقة التكرارية الأولى حتى نهاية الشهر

و ذلك يجعله اسرع

Option Explicit
Option Base 1
Sub My_Calandar1()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
    Dim t As Date, Search_Day As Date
    Dim Arab_day(), EnG_day()
    Dim i As Byte, m As Byte, r As Byte, _
         My_Max As Byte, rows_count As Byte
         
    rows_count = Range("b4").CurrentRegion.Rows.Count + 3
    Range("b4:H" & rows_count).ClearContents
    Range("b5:h10").Interior.ColorIndex = 0

 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
 t = DateSerial([b1], [b2], 1)
 My_Max = Day(Application.EoMonth(t, 0))
    '''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    Search_Day = DateSerial([b1], [b2], [g1])
    
        Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
'    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
   m = Weekday(t) + 1
    For i = 1 To My_Max
          With Cells(r, m)
           .Value = t
           .Interior.ColorIndex = 35
              t = t + 1
              m = m + 1
           If .Column > 7 Then r = r + 1: m = 2
          End With
    Next

    Range(Range("b5:h9").Find(Search_Day).Address).Interior.ColorIndex = 3

 Erase Arab_day
  
End Sub

**أ / محمد صالح** · فبراير 5, 2018

ولإثراء الموضوع يمكن اختصار الأكواد قليلا إلى هذا

Option Explicit
Option Base 1
Sub My_Calandar()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
Dim t As Date, i As Byte
Dim Arab_day(), m%
Dim EnG_day(), rows_count As Byte
Dim col As Byte
Dim r As Byte
Dim search_day As Date

rows_count = Range("b4").CurrentRegion.Rows.Count + 3
Range("b4:H" & rows_count).ClearContents
Range("b5:h10").Interior.ColorIndex = 0
 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
'''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    search_day = DateSerial([b1], [b2], [g1])
        Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
   '    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
      
    For i = 1 To 31
        t = DateSerial([b1], [b2], i)
        m = Weekday(t) + 1
        Cells(r, m) = t
        Cells(r, m).Interior.ColorIndex = IIf(t = search_day, 3, 35)
        If Month(t + 1) > [b2] Then Exit For
        r = IIf(m + 1 > 8, r + 1, r)
    Next
 Erase Arab_day
End Sub

نفعنا الله وإياكم بما علمنا وعلمنا ما ينفعنا

**سليم حاصبيا** · فبراير 5, 2018

للاختصار اكثر واكثر

Option Explicit
Option Base 1
Sub My_Calandar3()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
    Dim t As Date, Search_Day As Date
    Dim Arab_day(), EnG_day()
    Dim i As Byte, m As Byte, r As Byte, _
         My_Max As Byte, rows_count As Byte
         
    rows_count = Range("b4").CurrentRegion.Rows.Count + 3
    Range("b4:H" & rows_count).ClearContents
    Range("b5:h10").Interior.ColorIndex = 0

 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
 t = DateSerial([b1], [b2], 1)
 My_Max = Day(Application.EoMonth(t, 0))
    '''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    Search_Day = DateSerial([b1], [b2], [g1])
     Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
'    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
   m = Weekday(t) + 1
    For i = 1 To My_Max
          With Cells(r, m)
           .Value = t
              t = t + 1
              m = m + 1
         r = IIf(m > 8, r + 1, r)
         m = IIf(m > 8, 2, m)
         
          End With
    Next

    Range("b5:h9").SpecialCells(2).Interior.ColorIndex = 35
    Range(Range("b5:h9").Find(Search_Day).Address).Interior.ColorIndex = 3

 Erase Arab_day
  
End Sub

**أ / محمد صالح** · فبراير 5, 2018

4 ساعات مضت, أ / محمد صالح said:

ولإثراء الموضوع يمكن اختصار الأكواد قليلا إلى هذا


Option Explicit
Option Base 1
Sub My_Calandar()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
Dim t As Date, i As Byte
Dim Arab_day(), m%
Dim EnG_day(), rows_count As Byte
Dim col As Byte
Dim r As Byte
Dim search_day As Date

rows_count = Range("b4").CurrentRegion.Rows.Count + 3
Range("b4:H" & rows_count).ClearContents
Range("b5:h10").Interior.ColorIndex = 0
 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
'''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    search_day = DateSerial([b1], [b2], [g1])
        Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
   '    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
      
    For i = 1 To 31
        t = DateSerial([b1], [b2], i)
        m = Weekday(t) + 1
        Cells(r, m) = t
        Cells(r, m).Interior.ColorIndex = IIf(t = search_day, 3, 35)
        If Month(t + 1) > [b2] Then Exit For
        r = IIf(m + 1 > 8, r + 1, r)
    Next
 Erase Arab_day
End Sub

نفعنا الله وإياكم بما علمنا وعلمنا ما ينفعنا

عدد سطور الكود في مشاركتي 45 سطرا

3 ساعات مضت, سليم حاصبيا said:

للاختصار اكثر واكثر


Option Explicit
Option Base 1
Sub My_Calandar3()
 If ActiveSheet.Name <> "Salim_Calendar" Then Exit Sub
    Dim t As Date, Search_Day As Date
    Dim Arab_day(), EnG_day()
    Dim i As Byte, m As Byte, r As Byte, _
         My_Max As Byte, rows_count As Byte
         
    rows_count = Range("b4").CurrentRegion.Rows.Count + 3
    Range("b4:H" & rows_count).ClearContents
    Range("b5:h10").Interior.ColorIndex = 0

 '''''''''''''''''''''''''Conditions for working''''''''''''''''''
 If Not IsNumeric([b1]) Or Not IsNumeric([b2]) _
  Or [b1] < 1 Or [b2] > 12 Or [b2] < 1 Then
  MsgBox "Type Valid Numbers in cell(B1) & cell(B2)": Exit Sub
 End If
 ''''''''''''''''''''''''' End of Conditions for working''''''''''''''''''
 r = 5
 t = DateSerial([b1], [b2], 1)
 My_Max = Day(Application.EoMonth(t, 0))
    '''''''''''''''''''''''''Conditions for Special Day''''''''''''''''''
 If Not IsNumeric([g1]) Or [g1] > Day(Application.EoMonth(t, 0)) _
    Or [g1] < 1 Then
     [g1] = 1
       Else
     [g1] = Int([g1])
  End If
  '''''''''''''''''''''''''End of Conditions Special Day''''''''''''''''''
    Search_Day = DateSerial([b1], [b2], [g1])
     Arab_day = Array("الأحد", "الإثنين", "الثلاثاء", _
        "الأربعاء", "الخميس", "الجمعة", "السّبت")
'    EnG_day = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
    Range("b4").Resize(, 7) = Arab_day
   m = Weekday(t) + 1
    For i = 1 To My_Max
          With Cells(r, m)
           .Value = t
              t = t + 1
              m = m + 1
         r = IIf(m > 8, r + 1, r)
         m = IIf(m > 8, 2, m)
         
          End With
    Next

    Range("b5:h9").SpecialCells(2).Interior.ColorIndex = 35
    Range(Range("b5:h9").Find(Search_Day).Address).Interior.ColorIndex = 3

 Erase Arab_day
  
End Sub

بينما في المشاركة الثانية 53 سطرا

أعتقد كنت تقصد الإطالة أكثر أستاذ سليم

جل من لا يسهو

وعلى فكرة يمكن اختصاره إلى أقل من 45 سطرا

وفقنا الله جميعا لكل خير

تسجيل الدخول

Monthly Calendar

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

سليم حاصبيا

أ / محمد صالح

abo-mu7ammad

سليم حاصبيا

أ / محمد صالح

سليم حاصبيا

أ / محمد صالح

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information