اذهب الي المحتوي
أوفيسنا

Monthly Calendar

سليم حاصبيا

بواسطه سليم حاصبيا
في منتدى الاكسيل Excel

 مشاركة

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

سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

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

تسمية الصفحة التي تريد العمل عليها بهذا الاسم  "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

  • Like 7
  • Thanks 3
أ / محمد صالح

أ / محمد صالح

قام بنشر
قام بنشر

ما شاء الله

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

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

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

  • Like 1
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • الكاتب
قام بنشر

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

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

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

 

أ / محمد صالح

أ / محمد صالح

قام بنشر
قام بنشر

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

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

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

  • Like 3
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • الكاتب
قام بنشر

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

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

 

  • Like 1
أ / محمد صالح

أ / محمد صالح

قام بنشر
قام بنشر
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 سطرا

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

  • Like 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept