إدراج أيام شهور العام عند يوم محدد بإستخدام ال VBA

[سعيد بيرم]

السلام عليكم ورحمة الله وبركاته

لقد ساعدنى أخى وأستاذى الفاضل / محمد هشام  فى هذا الموضوع

لكن للأسف الملف لا يعمل معى ربما لإختلاف الإصدارين الذى نعمل عليهما

فأننى أستخدم إصدار 2010 وللأمانه كانت ردودى على الموضوع من خلال الصور التى شاركنى فيها أخى محمد

لهذا أطلب مد يد العون مرة أخرى لتحقيق هذا الموضوع ربما بإستخدام كود vba أو ربما بإستخدام  UDF Function

لقد قمت بتحديث الملف الذى يحاكى الملف الأصلى ****** برجاء الإطلاع وجزاكم الله خيراً

أيام الشهر من يوم محدد - vba.xlsm

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته 

الاستاذ محمد هشام  في المشاركة السابقة  اخبرك  (في حالة كنت تستخدم إصدار قديم  لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة) 

حسب ملفك الحالى كود في حدث الورقة كلما تم التغيير في M2  يتم التغيير في الاعمدة

الملف

أيام الشهر من يوم محدد - vba (1).xlsm

تم تعديل منذ 2 ساعات بواسطه عبدالله بشير عبدالله

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

5 ساعات مضت, سعيد بيرم said:

قمت بتحديث الملف الذى يحاكى الملف الأصلى

تفضل اخي تم تنفيد نفس الافكار السايقة على الملف المجدث 

 

 

او 

الاستغناء عن وضع الصيغة واستبدالها بكود في حدث ورقة1 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1")
    On Error GoTo CleanExit
    If Not Intersect(Target, Me.Range("m2")) Is Nothing Then
        Dim rCrit As Variant
        rCrit = xdates(Me.Range("m2").Value)
        With f.Range("k6:l" & f.Rows.Count)
            .ClearContents
        End With

        If Not IsEmpty(rCrit) Then
            Dim i As Long
            For i = LBound(rCrit) To UBound(rCrit)
                f.Cells(i + 5, 11).Value = rCrit(i, 1)
                f.Cells(i + 5, 12).Value = rCrit(i, 2)
            Next i
        End If
    End If

CleanExit:
End Sub

 

 

 

 

أيام الشهر من يوم محدد - vba1.xlsm

تم تعديل منذ 43 دقائق بواسطه محمد هشام.

[سعيد بيرم]

أخى وحبيبى فى الله / محمد هشام

أخى وحبيبى فى الله / عبدالله بشير

السلام عليكم ورحمة الله وبركاته

فى حقيقة الأمر أنا الأن فى حيرة من أمرى لمن أعطى أفضل إجابة

فكلا الحلين أكثر من رائع

أننى أشعر بطعامة المغاربه

وشقاوة الليبين

وجمال المصريين فى هذا الموضوع

عندما يلتقى الأشقاء فى التفكير والتنفيذ فستجدوا أجمل ما فى روحهم الطيبة

وسؤالى الأخير ونحن بصدد هذا الموضوع

ماذا لو أردنا عمل قائمة لإدراج أيام الشهر كاملا ودون إستثناءات للأيام 

إن كان الأمر كذلك فهنا وبذات الموضوع فضلا وليس أمرا

وإن لم يكن فسيتم طرح موضوع جديد

أما عن إختيار أفضل إجابة فهى 

لسعيد بيرم ههههههههههه 

بارك الله فيكم وجزاكم الله خير الجزاء 

تم تعديل منذ 2 ساعات بواسطه سعيد بيرم

[محمد هشام.]

13 دقائق مضت, سعيد بيرم said:

ماذا لو أردنا عمل قائمة لإدراج أيام الشهر كاملا ودون إستثناءات للأيام

اخي المسالة سهلة لا كن نظرا لشكل اشتغالك على الملف المفروض توضح لنا اكثر

1) هل تريد اظافة القائمة الى نفس قائمة اختيار الشهر M2 

2) طريقة الانشاء هل تحديد مثلا اسم الشهر والسنة في خلية معينة او مادا هناك عدة احتمالات واردة المرجوا شرح طلبك بالتفصيل 

[سعيد بيرم]

أخى محمد / ببساطة  شديدة على نفس الملف وبذات القائمة فى ال M2

ولكن على كامل الشهر دون إستثناء يومى الجمعة والسبت 

مثال على ذلك بداية أكتوبر الثلاثاء الموافق 2024/10/1 وينتهى فى الخميس الموافق 2024/10/31 وهكذا

شكرا لإهتمامك وجزاكم الله جميعا أنت وأخى عبدالله بشير خير الجزاء

[محمد هشام.]

7 دقائق مضت, سعيد بيرم said:

مثال على ذلك بداية أكتوبر الثلاثاء الموافق 2024/10/1 وينتهى فى الخميس الموافق 2024/10/31

لاكن اخي انت بحاجة لتغيير اسم الشهر بطريقة دينامكية على ما اعتقد  على الخلية M2 لهدا ربما ستحتاج الى اظافة 2 خلايا اخرى واحدة مثلا لاختيار السنة والاخرى لاختيار الشهر وبمجرد تحديدك للشهر والسنة المطلوبة يتم ادراج قائمة بجميع ايام الشهر المختار الى الخلية M2 ادا كان هدا يناسبك يمكننا فعل دالك بالاكواد 

ولو لديك اي فكرة اخرى ممكن تفيدك سوف تكون سعداء بمساعدتك

 

[عبدالله بشير عبدالله]

السلام عليكم

حقيقة كود الفاضل محمد هشام حاولت فهمه لم اتمكن من استيعابه بالكامل لانى حاولت التعدبل فيه بسبب الصورة المتحركة عند اختياره شهر 12 ظهر بالصورة بداية الشهر الاحد يوافق يوم 8 وحسب التقوبم الشهر يبدأ يوم 1 طبعا لم اجرب الملف كما قلت حسب الصورة المتحركة تأمل من استاذنا الفاضل تعدبل الكود للاستفاذة

 

ربما التعديل التالى لاختيار التاريخ يناسبك بمكن تعديل السنوات من الكود 

أيام الشهر من يوم محدد - vba (1).xlsm

 

 

 

تم تعديل منذ 1 ساعه بواسطه عبدالله بشير عبدالله

[محمد هشام.]

نشكرك اخي @عبدالله بشير عبدالله على الملاحظة 

فعلا لم انتبه الكود يقوم  بحساب أول يوم أحد بعد تاريخ البداية لذا إذا كان تاريخ البداية مثلا 1 ديسمبر وهو يوم الأحد بالفعل  الكود سيقوم بحساب الأحد الذي يليه أي 8 ديسمبر

تم تعديل الكود مع إظافة طلب أخونا @سعيد بيرم الأخير وهو  قائمة فى ال M2  ولاكن على كامل الشهر دون إستثناء يومى الجمعة والسبت

تعديل الدالة 

Function xdates(StartDate As Variant) As Variant
    Dim Dates() As Variant
    Dim Days() As String
    Dim Result() As Variant
    Dim tmp As Date, r As Date
    Dim n As Long, i As Long, maxday As Long
    
    If IsEmpty(StartDate) Or Not IsDate(StartDate) Then
        xdates = Array("")
        Exit Function
    End If

    maxday = 30 ' الحد الأقصى لعدد الأيام
    r = DateSerial(Year(StartDate), Month(StartDate) + 1, 0)
    
    ' العثور على أول يوم أحد
    tmp = StartDate + (7 - Weekday(StartDate, vbSunday)) Mod 7
    If Weekday(StartDate, vbSunday) = 1 Then
        tmp = StartDate
    End If

    ReDim Dates(1 To maxday)
    ReDim Days(1 To maxday)
    
    For tmp = tmp To r
        ' تجاهل يومي الجمعة (6) والسبت (7)
        If Weekday(tmp, vbSunday) <= 5 Then ' أيام الأحد إلى الخميس فقط
            n = n + 1
            Days(n) = Choose(Weekday(tmp, _
            vbSunday), "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس")
            Dates(n) = tmp
            
            If n >= maxday Then Exit For
        End If
    Next tmp

    ReDim Result(1 To n, 1 To 2)
        For i = 1 To n
        Result(i, 1) = Days(i)
        Result(i, 2) = Dates(i)
    Next i
    xdates = Result
End Function

والكود التالي لانشاء قائمة لايام الشهور المختارة واظافتها تلقائيا لخلية اختيار الشهر M2  مما يمكنه من تحديد بداية التاريخ المرغوب عرض بياناته 

 

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1")
    Dim rCrit As Variant, startRow As Long, startCol As Long
    Dim MonthValue As Integer, YearValue As Integer
    Dim StartDate As Date, EndDate As Date, n As Date, r As Long

    On Error GoTo CleanExit

    startRow = 5   ' رقم الصف
    startCol = 11  ' العمود (K)

    If Not Intersect(Target, WS.Range("M2")) Is Nothing Then
        rCrit = xdates(WS.Range("M2").Value)
        WS.Range("K6:L30").ClearContents

        If Not IsEmpty(rCrit) Then
            Dim i As Long
            For i = LBound(rCrit) To UBound(rCrit)
                WS.Cells(startRow + i, startCol).Value = rCrit(i, 1)
                WS.Cells(startRow + i, startCol + 1).Value = rCrit(i, 2)
            Next i
        End If
    End If

    If Not Intersect(Target, WS.Range("N1,O1")) Is Nothing Then
        MonthValue = WS.Range("N1").Value
        YearValue = WS.Range("O1").Value
        
        If MonthValue < 1 Or MonthValue > 12 Or YearValue < 1900 Or YearValue > 2100 Then
            MsgBox "يرجى إدخال قيم صحيحة للشهر والسنة"
            Exit Sub
        End If

        StartDate = DateSerial(YearValue, MonthValue, 1)
        EndDate = DateSerial(YearValue, MonthValue + 1, 0)

        r = 5
        n = StartDate

        WS.Range("Q5:Q50").ClearContents
        Do While n <= EndDate
            WS.Cells(r, 17).Value = n
            n = n + 1
            r = r + 1
        Loop
        Dim Rng As Range
        Set Rng = WS.Range(WS.Range("Q5"), WS.Range("Q" & r - 1))
        With WS.Range("M2").Validation
            .Delete
            .Add Type:=xlValidateList, Formula1:="=" & Rng.Address
            .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True
             
        End With
        WS.Range("M2").Value = StartDate
    End If

CleanExit:
End Sub

معادلة اظافية لتوليد ايام الشهور بشرط شهر الخلية N2 والسنة في الخلية O2 

=IF(ROW(A1) <= DAY(EOMONTH(DATE($O$1, $N$1, 1), 0)), DATE($O$1, $N$1, ROW(A1)), "")

مع سحبها للاسفل 

 

بالتوفيق..............

 

 

V3 أيام الشهر من يوم محدد - vba.xlsm