تسلسل الأيام بدون أيام الجمعة والسبت من تاريخ الى تاريخ بإستخدام VBA

[سعيد بيرم]

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

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

نطمع من حضراتكم فى إيجاد حل لهذا الموضوع

بإستخدام كود VBA  أو دالة معرفة UDF Function

حيث يحتوى المرفق على خليتين أحدهما لتاريخ بداية والأخرى لتاريخ نهاية

علما بأنه سيتم تسجيل هذين التاريخين يدويا 

والسؤال كيف يمكن إنشاء قائمة بتسلسل الأيام وبدون أيام الجمعة والسبت 

من تاريخ بداية  إلى تاريخ نهاية حسب مقتضيات العمل

 برجاء الإطلاع على العينة المرفقة والله الموفق وجزاكم الله خيرا

 

تسلسل الأيام بدون أيام الجمعة والسبت.xlsm

[محمد هشام.]

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

تاريخ بداية  إلى تاريخ نهاية

هل بداية الشهر او التاريخ المدخل 

[سعيد بيرم]

أخى محمد مساء الأنوار

ردا على سؤال حضرتك التاريخ المدخل وليس بداية الشهر

 

[محمد هشام.]

تفضل جرب هل هدا ما تقصده 

Option Explicit
Sub CreateDaysList()
    Dim Linge&, dCount&
    Dim startDate As Date, endDate As Date, n As Long
    Dim tmp As Date, cnt As String
    Dim sh As Worksheet: Set sh = Sheets("Sheet1")
   
   ' تحديد أقصى عدد للأيام المستخرجة
    Dim maxDays As Long: maxDays = 30
    
    startDate = sh.[L2].Value: endDate = sh.[M2].Value

   If IsEmpty(sh.[L2].Value) Or IsEmpty(sh.[M2].Value) Or _
       Not IsDate(sh.[L2].Value) Or Not IsDate(sh.[M2].Value) Or _
       sh.[L2].Value > sh.[M2].Value Then
        MsgBox "تاريخ البداية أو النهاية غير صحيح", vbExclamation: Exit Sub
    End If
    
    tmp = startDate
    n = 0

    Do While tmp <= endDate
        If Weekday(tmp) <> vbFriday And Weekday(tmp) <> vbSaturday Then
            n = n + 1
        End If
        tmp = tmp + 1
    Loop

        If n > maxDays Then
          MsgBox "عدد الأيام المستخرجة " & vbCrLf & _
                 "يتجاوز الحد الأقصى " & maxDays, vbExclamation
             Exit Sub
          End If
    Application.ScreenUpdating = False
    sh.Range("K6:L100").ClearContents
    Linge = 6
    tmp = startDate
    dCount = 0

    Do While tmp <= endDate
        If Weekday(tmp) <> vbFriday And Weekday(tmp) <> vbSaturday Then
            cnt = Choose(Weekday(tmp), "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس")
            sh.Cells(Linge, "L").Value = Format(tmp, "yyyy/mm/dd")
            sh.Cells(Linge, "K").Value = cnt
            Linge = Linge + 1
            dCount = dCount + 1
        End If
        tmp = tmp + 1
    Loop
    Application.ScreenUpdating = True
End Sub

 

 

تسلسل الأيام بدون أيام الجمعة والسبت 2.xlsm

تم تعديل الإثنين at 20:04 بواسطه محمد هشام.

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

السلام عليكم 

اثراء للموضوع وتنوع الحلول  وبعد اذن استاذنا الفاضل محمد هشام

الكود

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("L2:M2")) Is Nothing Then
        Dim startDate As Date
        Dim endDate As Date
        Dim currentDate As Date
        Dim outputRow As Long
        startDate = Me.Range("L2").Value
        endDate = Me.Range("M2").Value
        outputRow = 6
        Me.Range("K6:L" & Me.Rows.Count).ClearContents
        For currentDate = startDate To endDate
            If Weekday(currentDate, vbSunday) <> 6 And Weekday(currentDate, vbSunday) <> 7 Then
                Me.Cells(outputRow, 11).Value = Format(currentDate, "dddd")
                Me.Cells(outputRow, 12).Value = currentDate
                outputRow = outputRow + 1
            End If
        Next currentDate
    End If
End Sub

الملف

تسلسل الأيام بدون أيام 2الجمعة والسبت.xlsm

[سعيد بيرم]

زادكم الله فضلا واحتراما وأدبا

أخى محمد

كفيت ووفيت وجزاكم الله تعالى خير الجزاء

تقبل وافر تقديرى واحترامى

 

تم تعديل الإثنين at 21:08 بواسطه سعيد بيرم

[سعيد بيرم]

زادكم الله فضلا واحتراما وأدبا

أخى عبدالله

كفيت ووفيت وجزاكم الله تعالى خير الجزاء

تقبل وافر تقديرى واحترامى

[محمد هشام.]

العفو اخي @سعيد بيرم

هدا الملف يتضمن نفس الفكرة  مع استخراج الايام بداية من يوم الاحد على عمود A:B

 

 

 

 

ادراج أيام الشهر كاملا all .xlsm

تم تعديل الإثنين at 22:51 بواسطه محمد هشام.

[سعيد بيرم]

والله العظيم أستاذ ورئيس قسم يا إبنى

تسمح تجيب إيديك يا أبنى ابوسها ههههههههههه

ياللاه زى بعضة رغم أننى ستون عاما من العمر

لكنك فى القلب وربنا يبارك فى عمرك

طيب ياسيدى وارد جدا أن تتطلب مقتضيات العمل أن نعمل

على سبيل المثال لمدة شهرين من 2024/10/1 حتى 2024/11/30

كيف يمكن أن نقوم بعملية إنشطار لهذه القائمة إلى قائمتين متجاورتين

والسبب هو الحفاظ على حدود وهوامش الصفحة عند عملية الطباعة 

لمزيد من التوضيح برجاء الإطلاع على المرفق لمعرفة ما أعنيه

 

 

ادراج أيام الشهر كاملا all +111.xlsm

تم تعديل الثلاثاء at 00:36 بواسطه سعيد بيرم

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

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

صباح الخير 
الاستاذ سعيد بما اننا  في نفس العمر تقريبا 61 سنة    واشتراكنا بالمنتدى تقريبا فى نفس السنة بفارق عام اهديك هذا الملف  مع تحياتنا الخالصة لاخينا الاستاذ محمد هشام وادعو الله ان يمدكما بطول العمر ويمتعكما  بالصحة وراحة البال والرزق الوفير

بمكن كتابة تاريخ البدابة والتهاية يدوبا  في L2 -N2  فتتم العملية

الزر في الصفحة اخنياري ولبس اساسى مهمته انك تكتب تاربخ البداية بدويا ثم تكتب عدد الايام المراد اظافتها الى التاريخ في N3 ثم اضغط على الزر فبظفها الى تاريخ النهاية 

تحياتى لكما ولكل اخوتنا في هذا المنتدى

انقسام الشهور على قائمتبن.xlsm

 

 

تم تعديل الثلاثاء at 13:48 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

وارد جدا أن تتطلب مقتضيات العمل أن نعمل

على سبيل المثال لمدة شهرين من 2024/10/1 حتى 2024/11/30

كيف يمكن أن نقوم بعملية إنشطار لهذه القائمة إلى قائمتين متجاورتين

بصراحة اخجلتني بكلامه هدا  فأنت تقريبا بعمر والدي  بارك الله لك في عمرك و عملك و صحتك و اتم عليك نعمته و رزقك سعادة الدارين أنت وأستادنا @عبدالله بشير عبدالله  له خالص تقديري وامتناني على المجهود المتواصل لمساعدة الإخوة الأعضاء  كما يسعدني ويشرفني ولي الفخر أني قد شاركت معكم  حل هدا الموضوع

ما قام به أستادنا عبد الله  يوفي بالغرض 

1) ما جعلني أقوم بتعديل الكود الخاص بي على حسب متطلباتك الجديدة  هو أنني بعد تجربة الملف  الدي زودنا به أستادنا لاحظت هفوات بسيطة بطريقة الحساب في حالة كان عدد الايام المستخرجة اكبر من 64 صف

مثال لو قمنا بادخال

تاريخ البداية 2024/10/22 

تاريخ النهاية  2025/01/20

النتائج تظهر بشكل خاطئ  وعند إنقاص يوم تصبح صحيحة

2)  ضرورة إظافة شرط التحقق من التواريخ الصحيحة تفاديا للاخطاء  خاصة انك ستقوم بإدخال التواريخ يدويا 

3) تعريب أسماء الأيام 

جرب هدا 

Sub CreateDaysList()
    Dim startDate As Date, endDate As Date
    Dim xDate As Date, xCount As Long, cnt As Long, tmp As Long
    
    Dim sh As Worksheet: Set sh = Sheets("Sheet1")

    If IsEmpty(sh.[L2].Value) Or IsEmpty(sh.[N2].Value) Or Not IsDate(sh.[L2].Value) Or Not IsDate(sh.[N2].Value) Then
        MsgBox "يرجى إدخال تواريخ البداية والنهاية بشكل صحيح", vbExclamation
        Exit Sub
    End If

    startDate = sh.[L2].Value
    endDate = sh.[N2].Value

    If startDate > endDate Then
        MsgBox "تاريخ البداية يجب أن يكون أقل أو يساوي تاريخ النهاية", vbExclamation
        Exit Sub
    End If
    xDate = startDate
    cnt = 6
    tmp = 0
    xCount = 0
    Application.ScreenUpdating = False
    With sh.Range("K6:N64")
      .FormatConditions.Delete
       .ClearContents
    End With
    
    Do While xDate <= endDate And xCount < 64
        If Weekday(xDate, vbSunday) <> vbFriday And Weekday(xDate, vbSunday) <> vbSaturday Then
            sh.Cells(cnt, 11 + tmp).Value = Choose(Weekday(xDate, vbSunday), _
            "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس")
            sh.Cells(cnt, 12 + tmp).Value = Format(xDate, "yyyy/mm/dd")
            cnt = cnt + 1
            xCount = xCount + 1

            If cnt > 37 Then
                tmp = 2
                cnt = 6
            End If
        End If
        xDate = xDate + 1
    Loop
    Call crc(sh.Range("K6:K37"), "=K6=""الأحد""", RGB(255, 255, 0))
    Call crc(sh.Range("M6:M37"), "=M6=""الأحد""", RGB(255, 255, 0))

    Application.ScreenUpdating = True
End Sub
Sub crc(rng As Range, condition As String, color As Long)
    With rng.FormatConditions.Add(Type:=xlExpression, Formula1:=condition)
        .Interior.color = color
    End With
End Sub

ادراج أيام الشهر كاملا V4 .xlsm

وفي حدث ورقة 1

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sh As Worksheet: Set sh = Me
    If Not Intersect(Target, sh.Range("L2:N2")) Is Nothing Then
        Call CreateDaysList
    End If
End Sub

 

تم تعديل الثلاثاء at 15:14 بواسطه محمد هشام.

[سعيد بيرم]

بسم الله الرحمن الرحيم

وبه نستعين

أخى وأستاذى / عبدالله بشير

ما أجمل هدايكم المباركة والأجمل منها هى أن المولى العلى القدير أهدانى أخ كريم طيب النفس 

فلك منى خالص التحية والتقدير والإمتنان عما تقدمه للجميع هنا فتقبل الله تعالى منك صالح الأعمال

وجزاكم الله تعالى عنا خير الجزاء

 

[سعيد بيرم]

بسم الله الرحمن الرحيم

وبه نستعين

أخى وأستاذى / محمد هشام

حبيب قلبى ربنا يبارك فى والديك أولا ويبارك فى عمرك 

فاأنت وبحق من خيرة شباب الشقيقة المغرب

فبارك الله فى شبابك وأسعدكم الله تعالى فى الدارين

فكم أنا فخور بك ولدى العزيز الغالى

فلك منى خالص التحية والتقدير والإمتنان عما تقدمه للجميع هنا فتقبل الله تعالى منك صالح الأعمال

وجزاكم الله تعالى عنا خير الجزاء

 

تم تعديل الثلاثاء at 18:21 بواسطه سعيد بيرم

[سعيد بيرم]

أخى وأستاذى / عبدالله بشير

أخى وأستاذى / محمد هشام

تم وبحول الله تعالى تجربة كلا الكودين

وقد وفيتم وكفيتم 

وجزاكم الله تعالى عنا خير الجزاء