محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته بما انك اخي ترغب بتعبئة الفاتورة عن طريق اليوزرفورم مع إمكانية البحث بالحروف الأولى او اي جزء من الإسم في عمود البيان إليك طريقة أكثر ديناميكية ربما تناسبك Dim TabBD(), OnRng(), a() Private Sub UserForm_Initialize() Dim WS As Worksheet, c As Variant Dim lastRow As Long, dict As Object Set WS = ThisWorkbook.Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row a = WS.Range("C2:C" & lastRow).Value OnRng = Application.Transpose(WS.Range("B2:B" & lastRow).Value) Set dict = CreateObject("Scripting.Dictionary") For Each c In OnRng If Trim(c) <> "" Then dict(c) = "" End If Next c Me.ComboBox1.List = dict.keys End Sub '============ Private Sub Button1_Click() Dim lastRow As Range If Not Intersect(ActiveCell, ThisWorkbook.Sheets("Sheet1").Range("B15:B24")) Is Nothing Then If Me.ComboBox1 <> "" And Me.ComboBox2 <> "" Then ActiveCell.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then ActiveCell.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "يرجى إظافة البيانات", vbInformation Exit Sub End If Else Set lastRow = ThisWorkbook.Sheets("Sheet1").Range("B15:B24").Find(What:="", LookIn:=xlValues) If Not lastRow Is Nothing Then lastRow.Value = UCase(Me.ComboBox1) If Me.TextBox1 <> "" Then lastRow.Offset(, 1).Value = Me.TextBox1.Value End If Unload Me Else MsgBox "لا توجد خلايا فارغة متاحة في الفاتورة", vbInformation Exit Sub End If End If End Sub '=============== Private Sub ComboBox1_Change() If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, OnRng, 0)) Then Set dict = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1) & "*" For Each c In OnRng If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox1.List = dict.keys Me.ComboBox1.DropDown Else Search = UCase(Me.ComboBox1) If Search = "" Then Exit Sub ligne = 0 ReDim TabBD(1 To UBound(a)) For i = LBound(a) To UBound(a) If OnRng(i) = Search Then ligne = ligne + 1 TabBD(ligne) = a(i, 1) End If Next i ReDim Preserve TabBD(1 To ligne) Me.ComboBox2.List = TabBD If Me.ComboBox2.ListCount > 0 Then Me.ComboBox2.ListIndex = 0 End If End If End Sub '============ Private Sub ComboBox2_Change() If Me.ComboBox1 <> "" Then If Me.ComboBox2.ListIndex = -1 Then Set dict = CreateObject("Scripting.Dictionary") tmp = UCase(Me.ComboBox2) & "*" For Each c In TabBD If UCase(c) Like tmp Then dict(c) = "" Next c Me.ComboBox2.List = dict.keys Me.ComboBox2.DropDown Else tmp = Application.Match(Me.ComboBox2.Value, TabBD, 0) End If End If End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ComboBox1.Value = "" End Sub وفي حدث Sheet1 ضع الكود التالي Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect([B15:B24], Target) Is Nothing And Target.Count = 1 Then With UserForm2 .StartUpPosition = 0 .Left = Target.Left + 506 .Top = Target.Top + 30 - Cells(ActiveWindow.ScrollRow, 1).Top .Show End With End If End Sub فاتورة مبيعات مميزه 4.xlsm

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

لا اعلم أستاد @سيد الأكـرت لمادا انت مصر على عدم إرفاق عينة للنتائج المتوقعة يدويا هل هدا صعب

لا يمكنني فهم طلبك بدون إرفاق عينة من النتائج المتوقعة كما سبق الدكر أما بخصوص تنسيق الخلايا يمكنك تغيير التنسيق على حسب احتياجاتك بتعديل السطر التالي If IsDate(dest.Cells(Irow, i + 2).Value) Then dest.Cells(Irow, i + 2).NumberFormat = "m/d" ''<===== ' قم بتعديل تنسيق التاريخ بما يناسبك End If الى If Len(dest.Cells(Irow, i + 2).Value) > 0 Then dest.Cells(Irow, i + 2).NumberFormat = "@" ' تنسيق نص End If اما بخصوص حساب عدد الحصص الزائدة اسبوعيا عن طريق جمعها يمكنك تعديل الصيغة على الشكل التالي لتتمكن من جمع القيم التي تساوي أو أكبر من صفر مثلا عمود E =SUMIF(E16:E20, ">=0") مما يعني أنها ستتجاهل النصوص مثل "غ" أو "إجازة" وتجمع الأرقام فقط نفس الفكرة على عمود الجملة يمكنك استخدام الصيغة التالية مع سحبها للاسفل ستتجاهل النصوص بشكل تلقائي وتجمع فقط القيم الرقمية =SUM(E16, G16, I16, K16, M16) قد تم تعديل الكود والصيغ في الملف المرفق في المشاركة السابقة

ادا كنت قد فهمت طلبك بشكل صحيح ربما هدا سيوفي بالغرض سيتم تنفيد الكود عند التغيير في خلية التسلسل (K1) ورقة الأساسي Sub Test() Dim dest As Worksheet, WS As Worksheet Dim linge As String, arr As Variant Dim i As Long, LastRow As Long, OnRng As Range Dim Irow As Long, j As Long, Cnt As Long Dim dataArr As Variant Set WS = Sheets("البيانات") Set dest = Sheets("الأساسي") linge = dest.[K1].Value If linge = "" Then MsgBox "الرجاء إدخال تسلسل المعلم", vbExclamation: Exit Sub LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Set OnRng = WS.Range("A3:A" & LastRow).Find(What:=linge, LookIn:=xlValues, LookAt:=xlWhole) If Not OnRng Is Nothing Then arr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Irow = 9 ' <<===== ' تحديد الصف الأول للصق البيانات Cnt = 6 ' <<===== ' ( F عمود) بداية من يوم الأحـــــــــــــد Application.ScreenUpdating = False ' تكرار لكل يوم (من الأحد إلى الخميس) ReDim dataArr(0 To UBound(arr), 0 To 7) ' تخزين 5 أيام و8 أعمدة لكل يوم For j = 0 To UBound(arr) For i = 0 To 7 dataArr(j, i) = WS.Cells(OnRng.Row, Cnt + i).Value Next i Cnt = Cnt + 8 Next j For j = 0 To UBound(arr) For i = 0 To 7 dest.Cells(Irow, i + 2).Value = dataArr(j, i) If IsDate(dest.Cells(Irow, i + 2).Value) Then dest.Cells(Irow, i + 2).NumberFormat = "m/d" ''<===== ' قم بتعديل تنسيق التاريخ بما يناسبك End If Next i Irow = Irow + 1 Next j ' جلب المعلومات الإضافية dest.[C5].Value = WS.Cells(OnRng.Row, 2).Value ' اسم المعلم dest.[K5].Value = WS.Cells(OnRng.Row, 3).Value ' المادة dest.[P5].Value = WS.Cells(OnRng.Row, 4).Value ' الوظيفة dest.[S9].Value = WS.Cells(OnRng.Row, 5).Value ' النصاب ' إجراء الحسابات dest.[S8].Value = Application.WorksheetFunction.CountA(dest.Range("B9:I13")) dest.[S10].Value = dest.[S8].Value - dest.[S9].Value ' إظافة الدوائر بعد تنفيد الكود ' Call Draw_Circles Else MsgBox "لم يتم العثور على تسلسل المعلم" & linge, vbExclamation End If Application.ScreenUpdating = True End Sub صراحة لم أستوعب الفكرة حاول تزويدنا بعينة للنتائج المتوقعة بعد تجربة الاكواد السابقة الاجر V2.xls

جرب هدا Sub Draw_Circles() Const nMax As Integer = 38 Dim mx, v As Shape, x As Integer, r As Long, c As Long, cnt As Long Call Remove_Circles x = ActiveWindow.Zoom Application.ScreenUpdating = False ActiveWindow.Zoom = 100 mx = Range("s10").Value If mx = 0 Or Not IsNumeric(mx) Then MsgBox "Enter Valid Number In Cell s10", vbExclamation: GoTo Skipper For c = 8 To 2 Step -1 For r = 9 To 13 Step 1 With Cells(r, c) If .Value > 0 Then cnt = cnt + 1 Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 2, .Top + 2, .Width - 4, .Height - 4) v.Fill.Visible = msoFalse v.Line.ForeColor.SchemeColor = 10 v.Line.Weight = 2 If cnt = mx Then Exit For End If End With Next r If cnt = mx Then Exit For Next c cnt = 0 Skipper: ActiveWindow.Zoom = x Application.ScreenUpdating = True MsgBox "مبروك...", 64 End Sub

العفو اخي يسعدنا اننا استطعنا مساعدتك

لحذف الصفوف التي استلمت الدفعتين الأولى والثانية والإبقاء على الذين استلموا دفعة واحدة يمكنك القيام بذلك يدوياً بدون الحاجة إلى استخدام معادلة أو كود عن طريق اتباع الخطوات التالية: انقر على فلتر العمود "تاريخ الدفعة الثانية" (العمود C) قم بإلغاء تحديد القيم الفارغة بحيث تعرض الصفوف التي تحتوي على تاريخ في العمود "تاريخ الدفعة الثانية" بعد تطبيق الفلتر، حدد جميع الصفوف الظاهرة (هذه هي الصفوف التي استلمت الدفعتين) / اضغط بزر الماوس الأيمن على التحديد، واختر "حذف صف" (Delete Row) بعد حذف الصفوف، قم بإعادة تعيين الفلتر ليعرض جميع البيانات مرة أخرى بهذا الشكل ستحتفظ بالصفوف التي استلمت دفعة واحدة فقط

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا = "السيد/ مدير إدارة بمحافظة " & INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5:C100, ROW(C5:C100)-MIN(ROW(C5:C100)), 0, 1)), 0)) = "السيد/ مدير إدارة بمحافظة " & IFERROR(INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5:C100, ROW(C5:C100)-MIN(ROW(C5:C100)), 0, 1)), 0)), "لا توجد محافظة") او ="السيد/ مدير إدارة بمحافظة " & INDEX(C5:C100, MATCH(1, SUBTOTAL(103, OFFSET(C5, ROW(C5:C100)-ROW(C5), 0, 1)), 0)) طلب.xlsx

بما انك تستخدم ملف اخر يجب أولا الضغط على زر "Debug" في الرسالة لتحديد السطر البرمجي الذي يسبب الخطأ لنحاول اصلاحه رغم انه صراحة يصعب التعامل مع الاخطاء بهده الطريقة دون معاينة الملف الاصلي أما بخصوص الملف المرفق كما ترى الكود يقوم باظافة البيانات بدون ادنى مشكلة مع التحقق من وجود رقم الحساب مسبقا الملف بعد اظافة تسطير البيانات الجديدة وتنسيق ورقة العمل اليك الكود التالي لتلوين الصف النشط لان عملية حدف الصفوف من الممكن ان تأثر على التنسيق الشرطي الموجود مسبقا Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim f As Worksheet, Lr As Long Set f = ThisWorkbook.Sheets("home1") Lr = f.Cells(f.Rows.Count, "B").End(xlUp).Row Application.EnableEvents = False f.Range("B2:AX" & Lr).Interior.ColorIndex = xlNone If Not Intersect(Target, f.Range("B2:AX" & Lr)) Is Nothing And Target.Rows.Count = 1 Then f.Range("B" & Target.Row & ":AX" & Target.Row).Interior.Color = RGB(0, 255, 0) End If Application.EnableEvents = True End Sub برنامج المعطل 2024.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام احدى الصيغ التالية للحصول على عدد الذكور مع مراعاة الفلترة لان countif بمفردها لن تأخذ الفلاتر في الاعتبار =SUMPRODUCT(SUBTOTAL(103, OFFSET(K52:K750, ROW(K52:K750) - ROW(K52), 0, 1)), --(K52:K750="ذكر")) او =SUMPRODUCT((K52:K750="ذكر")*(SUBTOTAL(103,OFFSET(K52:K750,ROW(K52:K750)-ROW(K52),0,1)))) =SUMPRODUCT(SUBTOTAL(103, OFFSET(K52:K750, ROW(K52:K750) - ROW(K52), 0, 1)), --(K52:K750="أنثى")) او =SUMPRODUCT((K52:K750="أنثى")*(SUBTOTAL(103,OFFSET(K52:K750,ROW(K52:K750)-ROW(K52),0,1)))) القاعدة 2025 - Copy.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته لقد قمت بتجربة الملف المرفق من الاخ الفاضل @عبدالله بشير عبدالله يؤدي المطلوب مع عدم ظهور اي تواريخ غير موجودة كما في الصورة لديك على العموم تم اعادة تصحيح الاكواد الخاصة بك واختصارها بطريقة مختلفة مع ظافة بعض اللمسات البسيطة لتتناسب مع طلبك برنامج المعطل 2024.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim OnRng As Range, arr As Range, dict As Object, n As Long, f As String Dim lastRow As Long, SumCol As Long, a As Long Dim WS As Worksheet: Set WS = Me lastRow = WS.Columns("C:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not Intersect(Target, WS.Range("C6:D" & lastRow)) Is Nothing Then With Application .DisplayAlerts = False .ScreenUpdating = False If lastRow > 6 Then With WS.Range("E6:E" & lastRow) .UnMerge .ClearContents End With End If Set dict = CreateObject("Scripting.Dictionary") SumCol = WS.Cells(WS.Rows.Count, 3).End(xlUp).Row Set OnRng = WS.Range("C6:C" & SumCol) Set arr = WS.Range("D6:D" & SumCol) For n = 1 To OnRng.Rows.Count f = Trim(OnRng(n).Value) If Len(f) > 0 And IsNumeric(arr(n).Value) Then If dict.Exists(f) Then dict(f) = dict(f) + arr(n).Value Else dict.Add f, arr(n).Value End If End If If Len(Trim(arr(n).Value)) = 0 Then WS.Cells(n + 5, 5).Value = "" End If Next n n = 6 Do While n <= SumCol f = Trim(WS.Cells(n, 3).Value) If Len(f) > 0 Then If dict.Exists(f) Then WS.Cells(n, 5).Value = dict(f) a = n Do While n <= SumCol And Trim(WS.Cells(n, 3).Value) = f n = n + 1 Loop If n - a > 1 Then WS.Range(WS.Cells(a, 5), WS.Cells(n - 1, 5)).Merge End If Else n = n + 1 End If Else n = n + 1 End If Loop Set dict = Nothing .ScreenUpdating = True .DisplayAlerts = True End With End If End Sub جمع ودمج بشرط التاريخ.xlsm

اظن ان الكود المقترح من الاستاد @حسونة حسين يشتغل بشكل جيد على العموم جرب هدا Option Explicit Sub test() Dim arr As Variant, i As Long, Irow As Long Dim tmp1 As Object, tmp2 As Object, c As Variant Dim n As Variant, a As Variant, b As Variant Dim WS As Worksheet: Set WS = Sheets("Sheet1") Application.ScreenUpdating = False With WS Irow = .Columns("A:E").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Irow > 1 Then .Range("C2:E" & Irow).ClearContents End If arr = .Range("A2:B" & Irow).Value Set tmp1 = CreateObject("Scripting.Dictionary") Set tmp2 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(arr, 1) If arr(i, 1) <> "" Then tmp1(arr(i, 1)) = True If arr(i, 2) <> "" Then tmp2(arr(i, 2)) = True Next i For Each n In tmp1 If tmp2.exists(n) Then c = cnt(c, n) tmp2.Remove n Else a = cnt(a, n) End If Next n For Each n In tmp2 b = cnt(b, n) Next n If Not IsEmpty(a) Then [C2].Resize(UBound(a), 1).Value = WorksheetFunction.Transpose(a) If Not IsEmpty(b) Then [D2].Resize(UBound(b), 1).Value = WorksheetFunction.Transpose(b) If Not IsEmpty(c) Then [E2].Resize(UBound(c), 1).Value = WorksheetFunction.Transpose(c) Application.ScreenUpdating = True End With End Sub Function cnt(arr As Variant, Value As Variant) As Variant If IsEmpty(arr) Then ReDim arr(1 To 1) arr(1) = Value Else ReDim Preserve arr(1 To UBound(arr) + 1) arr(UBound(arr)) = Value End If cnt = arr End Function مقارنة 3.xlsb

INDEX او MATCH وحدهما لا تسمح لك بجمع نطاق متعدد الأعمدة بناءا على شروط معينة في نطاقات أخرى كما هو الحال مع SUMPRODUCT او SUMIFS لانها غالبا تستخدم لاستخراج قيمة واحدة من نطاق معين بشرط تطابق صف وعمود وليس لجمع نطاق كامل اما ادا كنت بحاجة الى بدائل تنفد نفس المهمة يمكنك استخدام احدى المعادلات التالية =SUMPRODUCT((($O$14:$O$17=I14)*($B$4:$B$7=J14)), MMULT(($C$4:$E$7), TRANSPOSE(COLUMN($C$4:$E$4)^0))) او =SUM(FILTER($C$4:$E$7, ($O$14:$O$17=I14)*($B$4:$B$7=J14))) او =SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$C$4:$C$7) + SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$D$4:$D$7) + SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*$E$4:$E$7) او =SUMIFS($C$4:$C$7, $O$14:$O$17, I14, $B$4:$B$7, J14) + SUMIFS($D$4:$D$7, $O$14:$O$17, I14, $B$4:$B$7, J14) + SUMIFS($E$4:$E$7, $O$14:$O$17, I14, $B$4:$B$7, J14) Officena 2.xlsx

أخي يصعب تتبع جميع الشروط للتأكد من صحة البيانات يرجى إظافة بعض التواريخ في اكثر من صف مع النتائج المتوقعة يدويا لنتمكن من تحديد مكان الخطأ

وعليكم السلام ورحمة الله تعالى وبركاته الخيار رقم 1 لاستخراج النتائج اظن انك بحاجة لفك الدمج على خلايا العمود A حيث أن الخلايا المدمجة تعتبر خلية واحدة في Excel مما يسبب تعارضا مع الدوال قم بإلغاء دمج الخلايا في العمود A (الصفوف 4 و 5) بحيث تصبح كل صف يحتوي على القيمة الصحيحة و بعد إلغاء الدمج استخدم المعادلة التالية =SUMPRODUCT(($A$4:$A$7=I14)*($B$4:$B$7=J14)*($C$4:$E$7)) إذا كنت تريد الاحتفاظ بالدمج يمكنك استخدام عمود مساعد (على سبيل المثال العمود O ) لتكرار القيم الموجودة في العمود A في الخلية O14 مثلا استخدم المعادلة التالية مع سحبها للاسفل =IF(A4<>"", A4, O13) استخدم المعادلة التالية في الخلية M14 لتستخدم العمود المساعد بدلًا من العمود المدمج A =SUMPRODUCT(($O$14:$O$17=I14)*($B$4:$B$7=J14)*($C$4:$E$7)) Officena (1).xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub Test_EvaluateConditions() Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim Irow As Long, n As Long, OnRng As Variant, a() As Variant Irow = WS.Cells(WS.Rows.Count, "N").End(xlUp).Row OnRng = WS.Range("J3:W" & Irow).Value ReDim a(1 To UBound(OnRng), 1 To 1) For i = 1 To UBound(OnRng, 1) n = Val(OnRng(i, 14)) * 365 + Val(OnRng(i, 13)) * 30 + Val(OnRng(i, 12)) a(i, 1) = Choose( _ Application.WorksheetFunction.Match( _ True, Array( _ OnRng(i, 9) <> "", _ OnRng(i, 8) = "" And n > 365, _ OnRng(i, 8) = "" And n <= 365, _ OnRng(i, 7) <> "" And n > 3 * 365, _ OnRng(i, 7) <> "" And n <= 3 * 365, _ OnRng(i, 6) <> "" And n > 6 * 365, _ OnRng(i, 6) <> "" And n <= 6 * 365 And n >= 3 * 365, _ OnRng(i, 6) <> "" And n < 3 * 365, _ OnRng(i, 5) <> "" And n >= 2 * 365, _ OnRng(i, 5) <> "" And n < 2 * 365 _ ), 0 _ ), _ "كبير", "الأول أ", "الأول ب", "الثاني أ", "الثاني ب", "الثالث أ", "الثالث ب", "الثالث ج", "الرابع أ", "الرابع ب" _ ) Next i WS.[X3].Resize(UBound(a, 1), 1).Value = a End Sub

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(LOOKUP(2,1/((سبتمبر!$E$4:$GH$4="السعر")*INDEX(سبتمبر!$E$5:$GH$1000,MATCH(C5,سبتمبر!$C$5:$C$1000,0),0)),سبتمبر!E5:GH5),"") المشتريات.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Function Father_Name(Name As Variant, Optional x As Variant) As Variant Dim tmp As String, s As String, n As Integer, d As Integer, j As Integer tmp = Trim(Name.Value) j = Len(tmp) s = " " If InStr(1, tmp, s) = 0 Then Father_Name = "" Exit Function End If Select Case True Case Left(tmp, 9) = "نور الهدى" n = InStr(10, tmp, s) + 1 Father_Name = Mid(tmp, n, j) Exit Function Case Left(tmp, 13) = "فاطمة الزهراء" n = InStr(14, tmp, s) + 1 Father_Name = Mid(tmp, n, j) Exit Function End Select If Not IsError(x) Then n = 1 For r = 2 To x n = InStr(n, tmp, s) + 1 Next r d = InStr(n, tmp, s) + 1 Father_Name = Mid(tmp, d, j) Else n = InStr(1, tmp, s) + 1 d = InStr(n, tmp, s) + 1 If Mid(tmp, 1, 3) Like "عبد*" Or Mid(tmp, 1, 3) Like "أبو*" Or _ Mid(tmp, n, 5) Like "الله" Or Mid(tmp, n, 5) Like "الدين" Then Father_Name = Mid(tmp, d, j) Else Father_Name = Mid(tmp, n, j) End If End If End Function استخراج اسم الاب من الاسم المركب.xlsm

يمكنك اظافة الكود التالي في اخر الكود مع تعديل عناوين الخلايا بما يناسبك If MsgBox("تفريغ بيانات التسجيل ", vbYesNo + vbQuestion, "تأكيـــد") = vbYes Then ws.Range("G3:G7").ClearContents End If MsgBox "تم ترحيل البيانات بنجاح", vbInformatio

تمام لاكنني لاحظت ان يوم 04/07/2024 في مثالك بعد 1 يوم هل هو خطا على العموم اظن ان المعادلة التالية ستوفي بالغرض =IF(A2="", "", IFERROR(IF($H$2>A2, "استحق الدفع", IF(A2=$H$2, "اليوم", "بعد "&A2-$H$2&" يوم")), "")) او =IF(A2="", "", IFERROR(IF($H$2>A2, "استحق الدفع", "بعد "&A2-$H$2&" يوم"), "")) معادلة لبيان المدة وعدم كتابة شيء في حالة الخلية فارغة.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده =IF(A2="", "", IF($H$2>A2, "استحق الدفع", ""))

لم يتم اخي الفاضل اظافة الكود انا في انتظار الرد على سؤالي ما هي طريقة ترحيل المشتريات هل سيتم النسخ الى صفحات المخازن وورقة المشتريات دفعة واحدة مع تحديث الكود او مادا على العموم على حسب ما فهمت الى غاية اللحظة ربما هدا ما تحاول فعله Sub TransferData2() Dim i As Long, Cnt As Long Dim ws As Worksheet, f As Worksheet, sWS As Worksheet Dim Sh As String, arr As Variant Dim tbl As ListObject, a As Range, lige As Range Dim j As String, newCode As String, b As String Set ws = ThisWorkbook.Sheets("تسجيل") Sh = ws.[G3].Value arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" ws.Activate: arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(Sh) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub Set tbl = f.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 ' الكود الجديد If Not lige Is Nothing Then j = lige.Value b = Left(j, Len(j) - Len(CStr(Val(j)))) Cnt = Val(Right(j, Len(j) - Len(b))) newCode = b & Cnt + 1 Else newCode = ws.[G4].Value End If If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ Set sWS = Sheets("المشتريات") Set tbl = sWS.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ End Sub مبيعات ومشتريات V1.xlsb