محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته 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) طريقة الانشاء هل تحديد مثلا اسم الشهر والسنة في خلية معينة او مادا هناك عدة احتمالات واردة المرجوا شرح طلبك بالتفصيل

نعم، ما ذكرته صحيح تماما استخدام Option Explicit في VBA يعتبر أمر جيد لأسباب عدة ومن فوائدها كدالك إعلان المتغيرات: يتطلب منك الإعلان عن جميع المتغيرات قبل استخدامها هذا يساعد على تجنب الأخطاء الناتجة عن الأخطاء المطبعية تحسين الأداء: يمكن أن يؤدي استخدام المتغيرات بشكل غير معلن إلى استخدام ذاكرة غير ضرورية عند الإعلان عنها يمكن للـ VBA تحسين الأداء سهولة التصحيح: عندما يحدث خطأ يكون من الأسهل تحديد مكان الخطأ حيث تعرف أنك قد أغلقت جميع المتغيرات المعلنة زيادة الوضوح: يجعل الكود أكثر وضوحا للآخرين الذين قد يقرأون كودك أو يعملون عليه مما يسهل فهم ما يحدث في كل جزء على كل حال أخي @سعيد بيرم إذا كنت تقوم بتطوير تطبيقات VBA أو تعمل على كود موجود فإن الالتزام باستخدام Option Explicit يمكن أن يساعدك بشكل كبير في الحفاظ على جودة الكود وتقليل الأخطاء شكرا لمشاركتك هذه المعلومة المهمة وجزاك الله خيرا للفائدة : افتح محرر VBA (Alt + F11) - انتقل إلى Tools ثم Options - في علامة التبويب Editor تأكد من تحديد خيار Require Variable Declaration بمجرد تفعيل هذا الخيار ستتم إضافة Option Explicit تلقائيا في أعلى كل وحدة نمطية جديدة تقوم بإنشائها مستقبلا

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

هدا بسبب عدم توافق نسخة الاوفيس لديك مع المعادلات المستخدمة على العموم لإثراء الموضوع أكثر اليك دالة تنفد المطلوب بادن الله عند التغيير في الخلية C2 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 في الخلية A6 =xdates(C2) في حالة الرغبة بإستخراج النتائج قيم يمكنك وضع الكود التالي في حدث ورقة Sheet1 Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim f As Worksheet: Set f = ThisWorkbook.Sheets("Sheet1") Dim rCrit As Variant, startRow As Long, startCol As Long On Error GoTo CleanExit startRow = 5 'رقم الصف startCol = 1 '(A)' أول عمود لوضع النتائج If Not Intersect(Target, Me.Range("C2")) Is Nothing Then rCrit = xdates(Me.Range("C2").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(startRow + i, startCol).Value = rCrit(i, 1) f.Cells(startRow + i, startCol + 1).Value = rCrit(i, 2) Next i End If End If CleanExit: End Sub قم تطبيق الفكرتين على نفس الملف لتختار ما يناسبك أيام الشهر من يوم محدد vba.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اظافة للكود المقترح من طرف الأستاد @عبدالله بشير عبدالله جزاه الله خيرا الحل بالمعادلات الخلية (O5) لجلب الأسماء بناء على وجود غياب (A) =IFERROR(INDEX($B$5:$B$8, SMALL(IF($D$5:$H$8="A", ROW($B$5:$B$8)-ROW($B$5)+1), ROW(A1))), "") الخلية (P5) لجلب تواريخ الغياب =IFERROR(INDEX($D$4:$H$4, SMALL(IF(INDEX($D$6:$H$8, MATCH(O5, $B$6:$B$8, 0), 0)="A", COLUMN($D$4:$H$4)-COLUMN($D$4)+1), COUNTIF($O$5:O5, O5))), "") مثال .xlsx

نعم اخي @سعيد بيرم سنقوم بتعديل المعادلات لإستخراج الأيام والتواريخ بداية من يوم الأحد من كل شهر مع تجاهل يوم الجمعة والسبت الخلية (A5) =IF(C2="", "", FILTER(CHOOSE(WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7) * (SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1) >= C2 + (7 - WEEKDAY(C2, 1)))), 1), "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس"), WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7) * (SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1) >= C2 + (7 - WEEKDAY(C2, 1)))), 1))) الخلية (B5) =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7) * (SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1) >= C2 + (7 - WEEKDAY(C2, 1))))) او =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, EDATE(C2, 0), 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, EDATE(C2, 0), 1), 1) < 6) * (SEQUENCE(DAY(EOMONTH(C2, 0)), 1, EDATE(C2, 0), 1) >= EDATE(C2, 0) + (7 - WEEKDAY(EDATE(C2, 0), 1))))) قم بتنسيق عمود التاريخ بما يناسبك ستظهر لك قائمة بأيام الشهر بدءا من أول يوم أحد وتجاهل يومي الجمعة والسبت لإستخراج عدد الأيام المتبقية في الشهر المحدد في الخلية (C2) =IF(C2="", "", COUNTA(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7) * (SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1) >= C2 + (7 - WEEKDAY(C2, 1)))))) بالتوفيق ........ في حالة كنت تستخدم إصدار قديم لن تشتغل معك الصيغ. أخبرني بذالك لمحاولة إنشاء دالة أو كود vba ينفذ نفس المهمة أيام الشهر من يوم V2 محدد.xlsx

المعادلات تشتغل معي بشكل جيد وتنفد المطلوب على العموم ادا كنت تقصد انك ترغب بظهور أسماء الأيام باللغة العربية جرب حل اخر كما هو موضح أسفله أسماء الأيام بالعربية =IF(C2="", "", FILTER(CHOOSE(WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1), "الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت"), WEEKDAY(FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5), 1))) التواريخ =IF(C2="", "", FILTER(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <= 5) * (WEEKDAY(SEQUENCE(DAY(EOMONTH(C2, 0)), 1, C2, 1), 1) <> 7))) =EOMONTH(DATE(2024, 9, 1), ROW(A1)-2) + 1 أيام الشهر من يوم محدد.xlsx