محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته في الخلية A4 ضع احدى المعادلات التالية مع سحبها يسارا لغاية عمود L وسحبها أسفل لغاية الصف الدي يناسبك =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, SMALL(IF('بيانات الطلاب'!$B$3:$B$100=$B$1, ROW('بيانات الطلاب'!$B$3:$B$100)-ROW('بيانات الطلاب'!B$3)+1), ROW(1:1))), "") أو =IFERROR(INDEX('بيانات الطلاب'!A$3:A$100, AGGREGATE(15, 6, ROW('بيانات الطلاب'!$B$3:$B$100) -ROW('بيانات الطلاب'!B$3)+1/( 'بيانات الطلاب'!$B$3:$B$100=$B$1), ROW(1:1))), "") أو =FILTER('بيانات الطلاب'!A$3:A$100, 'بيانات الطلاب'!$B$3:$B$100 = $B$1) متابعة الطلاب.xlsx باستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim d As Long, j As Long, clé As String, IRow As Long, col As Long Dim WS As Worksheet: Set WS = Worksheets("بيانات الطلاب") Dim F As Worksheet: Set F = Worksheets("متابعة الطلاب") If Not Intersect(Target, Me.Range("B1")) Is Nothing Then d = 4 clé = F.Range("B1").Value IRow = WS.Range("B3:B" & WS.Rows.Count).Find("*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Application.ScreenUpdating = False F.Range("A4:L" & F.Rows.Count).ClearContents For j = 3 To IRow If WS.Cells(j, 2).Value = clé Then For col = 1 To 12 F.Cells(d, col).Value = WS.Cells(j, col).Value Next col d = d + 1 End If Next j Application.ScreenUpdating = True End If End Sub متابعة الطلاب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي الإسم =IFERROR(INDEX(A!B$3:B$1000, SMALL(IF(A!$A$3:$A$1000=$E$4, ROW(A!$A$3:$A$1000)-ROW(A!$A$3)+1), ROW()-5)), "") التشخيصي =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0)), "") التقويم =IF(B6<>"", INDEX(A!C$3:AD$1000, MATCH(B6, A!B$3:B$1000, 0), MATCH($G$4, A!C$1:AD$1, 0) + 1), "") A.xlsx

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

هل تقصد ان جدول البيانات 2/ النوع و الجهة موجودة مسبقا على الجدول فقط يتم تجميع الأرقام و الشرط: عدم تكرار نفس النوع والجهة معاً ادا كان هدا ما تقصده يكفي وضع المعادلة التالية في عمود H =IF(AND(G4<>"", F4<>""), IFERROR(SUMIFS(D4:D100, C4:C100, G4, B4:B100, F4), ""), "") أما إدا كنت ترغب باستخراج البيانات بالشكل الواضح في الصورة بدون وضع بيانات مسبقا استخدم الكود التالي في حدث ورقة 1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim rng As Range Set rng = Intersect(Target, Me.Range("B4:D" & Me.Rows.Count)) If Not rng Is Nothing Then TotalNonTri End If End Sub Sub TotalNonTri() Dim a() As Variant, i&, lig&, key As Variant, tmp As Variant Dim WS As Worksheet, d As Object, tbl As Variant, n As String Set d = CreateObject("Scripting.Dictionary") Set WS = Sheets("Sheet1") tbl = Range("B4:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value Application.ScreenUpdating = False WS.Range("F4:H" & WS.Rows.Count).ClearContents For i = LBound(tbl, 1) To UBound(tbl, 1) If Not IsEmpty(tbl(i, 1)) And Not IsEmpty(tbl(i, 2)) Then n = tbl(i, 1) & "|" & tbl(i, 2) If d.Exists(n) Then d(n) = d(n) + tbl(i, 3) Else d(n) = tbl(i, 3) End If End If Next i ReDim a(1 To d.Count, 1 To 3) lig = 1 For Each key In d.Keys tmp = Split(key, "|") a(lig, 1) = tmp(0): a(lig, 2) = tmp(1): a(lig, 3) = d(key) lig = lig + 1 Next key With Range("F4").Resize(d.Count, UBound(a, 2)) .Value = a End With Application.ScreenUpdating = True End Sub Book1.xlsb

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

جرب هدا هل يناسبك توزيع فئات نقدية.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته 1) يصعب التعامل مع الصور اخي الكريم المفروض إرفاق ملف للاشتغال عليه 2) الصورة المرفقة للنتائج المطلوبة تتضمن فقط مخزن 1 ومخزن 2 اين هو 3 و4 3) عدم تحديد مكان وضع النتائج على حسب ما فهمت من طلبك المفروض النتيجة المتوقعة تكون على الشكل التالي

ادن جرب هدا Private Sub CommandButton24_Click() Dim a(2) As Long, b(2) As Double, arr As Variant Dim total(1) As Double, sum As Double, i As Integer arr = Array(200, 100, 50) For i = 0 To 2 If Not IsNumeric(Controls("TextBox" & (i + 1)).Value) Or Val(Controls("TextBox" & (i + 1)).Value) <= 0 Then MsgBox "الرجاء إدخال أعداد صحيحة موجبة فقط": Exit Sub End If a(i) = Val(Controls("TextBox" & (i + 1)).Value) b(i) = a(i) / 2 Controls("TextBox" & (4 + i)).Value = Int(b(i)) Controls("TextBox" & (7 + i)).Value = a(i) - Controls("TextBox" & (4 + i)).Value Controls("TextBox" & (16 + i)).Value = Controls("TextBox" & (4 + i)).Value * arr(i) Controls("TextBox" & (19 + i)).Value = Controls("TextBox" & (7 + i)).Value * arr(i) total(0) = total(0) + Controls("TextBox" & (16 + i)).Value total(1) = total(1) + Controls("TextBox" & (19 + i)).Value Next i sum = total(0) + total(1) If sum <> 0 Then Controls("TextBox11").Value = Format(total(0), "$#,##0.00") Controls("TextBox12").Value = Format(total(1), "$#,##0.00") Controls("TextBox10").Value = Format(sum, "$#,##0.00") Else MsgBox "حدث خطأ: الإجمالي الكلي يساوي صفرًا" End If Me.TextBox58 = Val(TextBox1) + Val(TextBox2) + Val(TextBox3) Me.TextBox59 = Val(TextBox4) + Val(TextBox5) + Val(TextBox6) Me.TextBox60 = Val(TextBox7) + Val(TextBox8) + Val(TextBox9) MsgBox "تم التوزيع بنجاح" End Sub توزيع فئات نقدية.xlsm

.

ضع الأكواد التالية في حدث ورقة natiga Private Sub Worksheet_Activate() UpdateData End Sub '============ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("A10:A25")) Is Nothing Then UpdateData End If End Sub '=========== Private Sub UpdateData() Dim ColmA As Variant, msg As String, i As Long, tmp As Variant, col As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Feuil1") Dim item As Range: Set item = WS.Range("K2:K9") Dim data As Range: Set data = WS.Range("L2:O9") For i = 10 To 25 ColmA = Me.Range("A" & i).Value Me.Range("B" & i).ClearContents If Trim(ColmA) = "" Then GoTo lig On Error Resume Next tmp = Application.Match(ColmA, item, 0) On Error GoTo 0 If Not IsError(tmp) Then msg = "بدون نتيجة" For col = data.Columns.Count To 1 Step -1 If Trim(data.Cells(tmp, col).Value) <> "" Then msg = data.Cells(tmp, col).Value Exit For End If Next col Me.Range("B" & i).Value = msg Else Me.Range("A" & i).Resize(1, 2).ClearContents MsgBox "الكود " & ColmA & " غير موجود", vbExclamation End If lig: Next i End Sub المعادلة =IF(A10="","",IFERROR(LOOKUP(2,1/(INDEX(Feuil1!$L$2:$O$9, MATCH(A10,Feuil1!$K$2:$K$9,0),0)<>""),INDEX(Feuil1!$L$2:$O$9,MATCH(A10,Feuil1!$K$2:$K$9,0),0)),"بدون نتيجة")) ppp7.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub Copier_tbl_Employe() Dim Code As String, lastrow As Long, n As Boolean Dim WS As Worksheet, dest As Worksheet Dim ColB As Variant, i As Long, tmp As Long Set WS = ThisWorkbook.Sheets("المصدر") Set dest = ThisWorkbook.Sheets("الهدف") tmp = 16: Code = dest.[B5].Value If Code = "" Then: MsgBox "الرجاء إدخال رقم الموظف", vbExclamation: Exit Sub lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row ColB = WS.Range("B1:B" & lastrow).Value n = False For i = 1 To UBound(ColB) If ColB(i, 1) = Code Then n = True Exit For End If Next i Application.ScreenUpdating = False If n Then With dest.Range("A5:I20") .UnMerge .ClearContents End With WS.Range("A" & i & ":I" & i + tmp).Copy With dest.Range("A5") .PasteSpecial Paste:=xlPasteAll End With Else MsgBox "لم يتم العثور على رقم الموظف : " & Code, vbExclamation End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub جلب بيانات اعتمادا على رقم الموظف.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك ذالك بتعديل كود إفراغ البيانات السابقة بهذا الشكل فقط ليتجاهل إفراغ عمود M With Union(sh.Range("K6:L64"), sh.Range("P6:Q64")) .FormatConditions.Delete .ClearContents End With لتضمينها داخل الكود With sh .Range("M3").Formula = "=COUNTIF(M6:M37, ""حضور"") + COUNTIF(R6:R37, ""حضور"")" .Range("N3").Formula = "=COUNTIF(M6:M37, ""غياب"") + COUNTIF(R6:R37, ""غياب"")" .Range("P3").Formula = "=COUNTIF(M6:M37, ""اجازة"") + COUNTIF(R6:R37, ""اجازة"")" .Range("Q3").Formula = "=IF(SUM(N6:N37, S6:S37) = 0, """", SUM(N6:N37, S6:S37))" End With COUNTIF.xlsm

=IF(A14="","",IFERROR(LOOKUP(2,1/(INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)<>"") ,INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)),"بدون نتيجة")) معادلة الأستاد @عبدالله بشير عبدالله =IFERROR( IF(A14="", "", INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), AGGREGATE(14, 6, COLUMN($L$1:$O$1) / (INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), 0)<>""), 1) - COLUMN($L$1) + 1) ), "بدون نتيجة") Private Sub Worksheet_Change(ByVal Target As Range) Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("K2:K9") Set rngB = Me.Range("L2:O9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(rngB.Cells(tmp, col).Value) <> "" Then result = rngB.Cells(tmp, col).Value Exit For End If Next col cell.Offset(0, 1).Value = result Else cell.Resize(1, 2).ClearContents MsgBox "الكود " & cell.Value & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp6.xlsb

بصراحة اخجلتني بكلامه هدا فأنت تقريبا بعمر والدي بارك الله لك في عمرك و عملك و صحتك و اتم عليك نعمته و رزقك سعادة الدارين أنت وأستادنا @عبدالله بشير عبدالله له خالص تقديري وامتناني على المجهود المتواصل لمساعدة الإخوة الأعضاء كما يسعدني ويشرفني ولي الفخر أني قد شاركت معكم حل هدا الموضوع ما قام به أستادنا عبد الله يوفي بالغرض 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

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

تفضل جرب هل هدا ما تقصده 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

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

اخي @mahmoud nasr alhasany خاصية ColumnHeads = True في عنصر التحكم ListBox لا تعمل إلا إذا كانت البيانات مرتبطة مباشرة بنطاق خلايا من ورقة العمل باستخدام خاصية RowSource عندما تستخدم الطريقة AddItem لإضافة البيانات يدويا لن يتم عرض رؤوس الأعمدة حتى لو قمت بتعيين ColumnHeads = True حاول إضافة رؤوس الأعمدة باستخدام عناصر Label بدلا من الاعتماد على رؤوس الأعمدة داخل الـ ListBox يمكنك تحديدها داخل كود تهيئة اليوزرفورم بعد اظافة عناصر label جديدة بعدد العناوين المرغوب عرضها وتسميتها بإسم مختلف لكي لا يتعارض الكود مع العناصر السابقة مثلا (hrd1- hrd2-...-hrd6) Private Sub UserForm_Initialize() 'الكود الخاص بك Dim arr As Variant arr = Array("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") For i = 1 To 6 Me("hrd" & i).Caption = arr(i - 1) Next i End Sub وتعديل الكود على Private Sub CommandButton1_Click() With ListBox2 .Clear .ColumnCount = 6 .ColumnWidths = colWidths .Font.Size = 10 End With currentRow = 0 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ' كود ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ' صنف ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ' سعر ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ' كمية المخزون ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ' اسم المخزن ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value ' تاريخ نهاية الصنف currentRow = currentRow + 1 End If Next i عملية بحث بشرطين او اكثر.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Private Sub TextBox1_Change() Dim WS As Worksheet: Set WS = ActiveSheet Dim LastRow As Long, OnRng As Range LastRow = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("A2:AE" & LastRow) If Me.TextBox1.Value = "" Then If WS.AutoFilterMode Then WS.AutoFilterMode = False End If Else OnRng.AutoFilter Field:=3, _ Criteria1:=Me.TextBox1.Value & "*", Operator:=xlOr, Criteria2:=Me.TextBox1.Value End If End Sub

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Sub CommandButton1_Click() Dim ws As Worksheet Dim lastRow As Long Dim searchValue1 As String Dim searchValue2 As String Dim currentRow As Long Dim colHeaders As Variant searchValue1 = ComboBox1.Value searchValue2 = ComboBox3.Value Set ws = Worksheets("Sheet3") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' تعريف رؤوس الأعمدة colHeaders = Array("كود", "صنف", "سعر", "كمية المخزون", "اسم المخزن", "تاريخ نهاية الصنف") colWidths = "35;60;45;40;65;40" With ListBox2 .Clear .ColumnCount = UBound(colHeaders) + 1 .ColumnWidths = colWidths .Font.Size = 10 .AddItem For i = 0 To UBound(colHeaders) .List(0, i) = colHeaders(i) Next i End With currentRow = 1 For i = 2 To lastRow If ws.Cells(i, 5).Value = searchValue1 And _ ws.Cells(i, 1).Value Like "*" & searchValue2 & "*" Then ListBox2.AddItem ListBox2.List(currentRow, 0) = ws.Cells(i, 1).Value ListBox2.List(currentRow, 1) = ws.Cells(i, 2).Value ListBox2.List(currentRow, 2) = ws.Cells(i, 3).Value ListBox2.List(currentRow, 3) = ws.Cells(i, 4).Value ListBox2.List(currentRow, 4) = ws.Cells(i, 5).Value ListBox2.List(currentRow, 5) = ws.Cells(i, 6).Value currentRow = currentRow + 1 End If Next i If ListBox2.ListCount = 1 Then MsgBox "لم يتم العثور على نتائج" End If TextBox7.Text = "عدد السجلات في القائمة : (" & ListBox2.ListCount - 1 & ")" Call TOtal End Sub

ادا كنت تقصد نفس الملف فهدا ما تم تنفيده مسبقا اختيار اسم الشهر من N1 والسنة من O1 يتم انشاء القائمة على M2 أظن ان هدا طلب مغاير عن ماجاء في أول مشاركة لك .لكي لا نخرج عن إطار طلبك الأول حاول فتح موضوع جديد بطلبك

نشكرك اخي @عبدالله بشير عبدالله على الملاحظة فعلا لم انتبه الكود يقوم بحساب أول يوم أحد بعد تاريخ البداية لذا إذا كان تاريخ البداية مثلا 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

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

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