محمد هشام.

جرب هدا 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

تم تعديلها مع اظافة امكانية جلب اخر كود في الصفحة الهدف عند التغيير في الخلية G3 جرب هدا للمبيعات Sub TransferData1() Dim ws As Worksheet, dest As Worksheet, sWS As Worksheet Dim arr As Variant, xdate As String Dim Clé As String, a As Range, n As Range Dim Sht As String, tbl2 As ListObject, Irow As Range xdate = Format(Date, "dd/mmmm") Set ws = Sheets("تسجيل") Sht = ws.Range("C3").Value On Error Resume Next Set dest = Sheets(Sht) On Error GoTo 0 If dest Is Nothing Then MsgBox "صفحة المخازن" & Sht & " غير موجودة", vbExclamation Exit Sub End If Set sWS = Sheets("المبيعات") Clé = ws.Range("C4").Value arr = Array(ws.Range("C4").Value, ws.Range("C5").Value, ws.Range("C6").Value, ws.Range("C7").Value) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & ws.Cells(4 + i, 2).Value, vbExclamation, "تنبيه" ws.Activate ws.Cells(4 + i, 3).Select Exit Sub End If Next i Set a = dest.Columns("C").Find(What:=Clé, After:=dest.Cells(4, 3), LookIn:=xlValues, LookAt:=xlWhole) If a Is Nothing Then MsgBox "لم يتم العثور على ُمعرّف المخزون " & Clé, vbExclamation Exit Sub End If a.Offset(0, 2).Value = arr(1) a.Offset(0, 6).Value = arr(2) a.Offset(0, 7).Value = arr(3) a.Offset(0, 5).Value = 1 a.Offset(0, 9).Value = xdate Set tbl2 = sWS.ListObjects(1) Set Irow = tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not Irow Is Nothing Then Set n = Irow.Offset(1).Resize(1, tbl2.ListColumns.Count) Else Set n = tbl2.ListRows(1).Range.Resize(1, tbl2.ListColumns.Count) End If n.Cells(1, 1).Offset(0, -1).Value = xdate n.Cells(1, 1).Resize(1, 10).Value = a.Resize(1, 10).Value MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub بالنسبة للمشتريات هل الترحيل للورقة المختارة او لورقة المشتريات مع مراعات تسلسل كود الصنف مبيعات ومشتريات V1.xlsb

ادن ما نفهمه الان انك رغم ادخالك مثلا w3 يتم تجاهله واظافة كود جديد w4

انا بتكلم عند الترحيل الى صفحات المخزون هناك شيء غير مفهوم لكي نكون اكثر وضوحا جرب هدا لترحيل البيانات الى صفحات المخزون وورقة المبيعات ووافيني بالنتيجة Sub CopyDatasale() Dim ws As Worksheet, f As Worksheet, dest As Worksheet Dim Sh As String, arr As Variant, rngToCopy As Range Dim tbl As ListObject, Tbl2 As ListObject, i& Dim OnRng As Range, Irow As Range, a As Range, n As Range Set ws = Sheets("تسجيل") Set dest = Sheets("المبيعات") Sh = ws.[C3].Value: Set f = ThisWorkbook.Sheets(Sh) arr = Array(ws.[C4], ws.[C5], ws.[C6], ws.[C7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه": ws.Activate: arr(i).Select: Exit Sub 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 Dim MSg As VbMsgBoxResult MSg = MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") If MSg = vbNo Then Exit Sub Set tbl = f.ListObjects(1) Set Tbl2 = dest.ListObjects(1) Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not OnRng Is Nothing Then Set a = OnRng.Offset(1) Else Set a = tbl.ListRows(1).Range End If '==== ترحيل البيانات إلى ورقة المخزون ===== a.Cells(1, 1).Value = arr(0) ' كود الصنف a.Cells(1, 3).Value = arr(1) ' الاسم a.Cells(1, 6).Value = 1 ' الكمية a.Cells(1, 4).Value = arr(2) ' الوصف a.Cells(1, 8).Value = arr(3) ' الملاحظات a.Cells(1, 10).Value = Format(Date, "dd/mmmm") ' التاريخ Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) Set Irow = Tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) If Not Irow Is Nothing Then Set n = Irow.Offset(1).Resize(1, 10) Else Set n = Tbl2.ListRows(1).Range.Resize(1, 10) End If '==== ترحيل البيانات إلى ورقة المبيعات ===== Set rngToCopy = OnRng.Resize(1, 10) n.Value = rngToCopy.Value n.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") End Sub

يعني مسالة تكرار الكود واردة

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