مالخطاء فى هذا الكود

[mahmoud nasr alhasany]

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

100: المنتج:12: مخزن : 01/05/2024
100: المنتج:26: مخزن : 01/01/2024

عندما تكون الكمية 26 (صفر)، فإنها تقوم بالحذف نهائى عندما تتوافر الشروط كود (المنتج واسم المخزن)+ الصلاحية
أما بالنسبة للمنتج لهذا المخزن
عندما تكون الكمية 12 (صفر) لايقوم يحذفه لأنه غير مكرر
مثل
100: المنتج: 12: مخزن: 01/05/2024
الى

100: المنتج: 0: مخزن: 01/05/2024

يوجد صورة مدرجة للتوضيح قبل المطلوب تنفيذة وبعد تنشيط الكود

واكون شاكر جداااا للمساعدة فقد يأست من تنفيذ ونجاح ورقة العمل

يوجد مشكلة فى الكود

Sub KeepZeroDuplicates()
Dim ws As Worksheet
Dim lastRow As Long
Dim checkRange As Range
Dim checkCols As Variant
Dim data As Variant
Dim i As Long, j As Long, k As Long
' Set worksheet and last row
Set ws = ActiveSheet ' Replace with your sheet name if needed
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Adjust column if needed
' Specify columns to check for duplicates and zero values
checkCols = Array(1, 2, 3, 4, 5) ' Replace with column numbers
' Store data in an array for efficient processing
data = ws.Range("A1:E" & lastRow).Value ' Adjust range as needed
' Loop through data array
For i = 2 To UBound(data, 1) ' Start from second row
For j = 2 To i - 1
' Check for duplicate in specified columns
If IsDuplicate(data, i, j, checkCols) Then
' Check if any value in check columns is zero
For k = LBound(checkCols) To UBound(checkCols)
If data(i, checkCols(k)) = 0 Then Exit For
Next k
If k <= UBound(checkCols) Then
' Duplicate found with zero value, keep it
Exit For
Else
' Duplicate without zero value, delete row
ws.Rows(i).Delete
i = i - 1
Exit For
End If
End If
Next j
Next i
End Sub
Function IsDuplicate(data As Variant, row1 As Long, row2 As Long, checkCols As Variant) As Boolean
Dim k As Long
For k = LBound(checkCols) To UBound(checkCols)
If data(row1, checkCols(k)) <> data(row2, checkCols(k)) Then
IsDuplicate = False
Exit Function
End If
Next k
IsDuplicate = True
End Function

 

تم تعديل أغسطس 3 بواسطه mahmoud nasr alhasany

[mahmoud nasr alhasany]

Stock123.xlsm

هذا هو الملف

انا اقصد عندما يكون كودالمنتج مع اسم المخزن اذا كانت الكمية صفر ولايوجد غيرة فلايقوم بحذفة

ولاكن لو نظرت ان كودالمنتج مع اسم المخزن مكرر مع العلم ان يوجد رصيد فى المخزن وهى الكمية( 12 )

الكود مفعل على ان  كودالمنتج مع اسم المخزن و الكمية لو تكررت برقم (صفر) يقوم بحزفها مع العلم ان يوجد رقم (12) موجود

 

 

اريد دمج كود المنتج مع اسم المخزن  لان المقصود بالتكرار ليس الكمية صفر ولاكن معها كود المنتج واسم المخزن معا

وهذا للايضاح

 

بأختصار يقوم بحذف الكمية لو كانت صفر اذا توافر كود المنتج واسم المخزن مكرر

ولو كان كود المنتج واسم المخزن  غير مكرر وكانت الكمية صفر فلايقوم بحذفها

ملحوظة

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

 

[AbuuAhmed]

وهذا تنقيح للكود بطريقتي:
 

Sub RemoveZeroDuplicates()
    Dim ws As Worksheet, count As Long
    Dim row As Long, lRow As Long
    
    Application.ScreenUpdating = False
    
    Sheets("Sheet3").Select
    Set ws = ActiveSheet
    
    With ws
        lRow = ActiveCell.SpecialCells(xlLastCell).row
        
        For row = lRow To 2 Step -1
            If .Cells(row, 8) = "Yes" Then
                count = count + 1
                .Rows(row).Delete Shift:=xlUp
            End If
        Next row
    End With
    
    Application.ScreenUpdating = True
    MsgBox "تم حذف " & count & " سجل"
End Sub

 

[mahmoud nasr alhasany]

انظر لقد رأيت المشكلة

موضحة فى الشرح داخل ملف الاكسيل

Copy of Stock123.xlsm

[AbuuAhmed]

هل جربت الكود في مشاركتي قبل الأخيرة ولم ينجح؟!!
عموما أنا حليت لك أكبر مشكلتين في الكود:
أولهما مفتاح التكرار حيث بدلته من:
 

checkCols = Array(1, 2, 3, 4, 5)

إلى:
 

checkCols = Array(1, 4, 5)

وكذلك تبديل عملية الحذف بحيث تكون من الأخير إلى الأول وهنا لا تحتاج إلى ضبط متغير row1 بعد كل عملية حذف ولا نحتاج لمقاطعة حلقة التكرار.

يفترض أنك تراعي تعبنا بدلا من أن تأخذ جزء من هنا وجزء من هناك ثم ترجع بعبارة رأيت المشكلة أو وجدت الحل.
ميزة الحل السابق أن يحافظ على ترتيب الادخال.

سؤال لك الخيار في الرد عليه: هل التعديلات من عملك أم هناك من تتواصل معه خارج المنتدى؟
 

[mahmoud nasr alhasany]

 

 

 

 

 

 

 

 

 الف شكر

AbuuAhmed

[AbuuAhmed]

في 5‏/8‏/2024 at 15:06, AbuuAhmed said:

هل جربت الكود في مشاركتي قبل الأخيرة ولم ينجح؟!!

إلى المشرفين المحترمين:
لماذا تم حذف هذه المشاركة المشار إليها في سؤالي!!
حذف آخر كود منقح يحرف المناقشة عن مفهومها الصحيح!! وفيها خلاصة الحل (الزبدة).

نسخة مع التحية إلى @محمد طاهر عرفه

الكود المحذوف والمقصود في سؤالي أعلى المشاركة:
 

Sub KeepZeroDuplicates()
    Dim ws As Worksheet, CheckRange As Range
    Dim data As Variant, checkCols As Variant
    Dim row1 As Long, row2 As Long

    Application.ScreenUpdating = False
    
    'Set worksheet and last row
    Set ws = ActiveSheet 'Replace with your sheet name if needed
    row1 = ws.Cells(ws.Rows.count, "A").End(xlUp).row
    'Store data in an array for efficient processing
    data = ws.Range("A1:E" & row1).Value 'Adjust range as needed
    
    'Specify columns to check for duplicates
    checkCols = Array(1, 4, 5) 'Replace with column numbers
    
    'Loop through data array
    For row1 = 2 To UBound(data) 'Start from second row
        For row2 = 2 To row1 - 1
            DoEvents
            'Check for duplicate in specified columns
            If IsDuplicate(data, row1, row2, checkCols) Then
                'If Duplicate and zero quantity
                If data(row1, 3) = 0 Then
                    ws.Cells(row1, 1) = "2Del"
                    Exit For
                End If
            End If
        Next row2
    Next row1

    For row1 = UBound(data) To 2 Step -1
        If Cells(row1, 1) = "2Del" Then
            Rows(row1).Delete Shift:=xlUp
        End If
    Next row1

    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub



Function IsDuplicate(data As Variant, row1 As Long, row2 As Long, checkCols As Variant) As Boolean
    Dim index As Long

    For index = LBound(checkCols) To UBound(checkCols)
        If data(row1, checkCols(index)) <> data(row2, checkCols(index)) Then
            Exit Function
        End If
    Next index

    IsDuplicate = True
End Function

 

تم تعديل أغسطس 6 بواسطه AbuuAhmed
تصحيح أخطاء مطبعية

[AbuuAhmed]

أنا لا أعرف ما الهدف من حذف نقاش في صلب الموضوع!!
اترك المناقشة كما هي لأن فيها تبيان لمعاناة بعض المتصدين لأسئلة الأعضاء.

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

يوجد في منتدى آخر من منتديات أوفيسنا تحشر "دردشة خاصة" بين المشرفين والمراقبين ليس لها علاقة بالعلم ولا البرمجة ولا الموضوع نفسه بل عبارة عن نكت ومزاح وقصص ومجاملات وغيره وتمر دون أن يتدخل أحد بحذفها، وأنتم هنا ما شاء الله تريد تأخذ أول سؤال وآخر جواب وتحذفون ما ترونه من وجه نظركم غير مفيد.

قننوا الصلاحيات.

[محمد طاهر عرفه]

السلام عليكم

أخي أبو أحمد

أولا نشكرك على جهودك المميزة

ثانيا ، لم يحذف شييء فقط تم اخفاء الخطوات البينية قبل الوصول للحل تسهيلا على المتابعين حاليا و مستقبلا ، فأظن أننا نتفق أن كودك الاخير هو الافضل و الذي تم الابقاء عليه ظاهرا و اختير كافضل اجابة
و الردود السابقة لم تحذف ، و هي موجودة يمكن استرجاعها اذا دعت الحاجة ـ و هذا الأمر يمكن بالطبع أن تكون فيه وجهات نظر مختلفة ،
قد تكون محقا ككاتب للموضوع و بذلت جهد مشكور  فيه تفضل الابقاء على كل المحاولات ، و من ناحية أخرى قد نكون كفريق عمل محقين فى الاباقاء على أفضل الحلول و الذي هو ايضا حلك تسهيلا على قراء الموضوع الحاليين و المستقبليين  ، و لنعذر بعضنا بعضا فى نقاط الاختلاف
حاليا الكود الافضل موجود و مختار :افضل اجابة
و شكرا لك مقدما  على تفهمك

 

[mahmoud nasr alhasany]

احسنت استاذنا الفاضل / محمد طاهر عرفه

وايضا اشكر السيد  / AbuuAhmed

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

 

تم تعديل أغسطس 7 بواسطه mahmoud nasr alhasany

[mahmoud nasr alhasany]

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

وعندما اضفت كود اخر وهى   SortData 

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

Sub RemoveDuplicatesWithMultipleConditions1()
    Dim lastRow As Long
    Dim i As Long, j As Long
    Set ws = Sheet3
      SortData
    ' Find the last row with data
    lastRow = ws.Cells(Rows.count, "A").End(xlUp).row
    ' Loop through the data
    For i = lastRow To 2 Step -1
        For j = i - 1 To 1 Step -1
            ' Check for duplicate conditions
            If Cells(i, "A").Value = Cells(j, "A").Value And _
               Cells(i, "b").Value = Cells(j, "b").Value And _
               Cells(i, "c").Value = 0 And _
               Cells(i, "d").Value = Cells(j, "d").Value Then
                Rows(i).Delete
                Exit For
            End If
        Next j
    Next i
End Sub

Sub SortData()
Columns.Sort key1:=Columns("a"), Order1:=xlAscending, Key2:=Columns("c"), Order2:=xlDescending, Header:=xlYes
End Sub

 

تم تعديل أغسطس 7 بواسطه mahmoud nasr alhasany

[AbuuAhmed]

وعليكم السلام

حياك الله أخي محمد،

منذ ساعه, محمد طاهر عرفه said:

لم يحذف شييء فقط تم اخفاء الخطوات البينية قبل الوصول للحل تسهيلا على المتابعين حاليا و مستقبلا

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

اقتباس

فأظن أننا نتفق أن كودك الاخير هو الافضل و الذي تم الابقاء عليه ظاهرا و اختير كافضل اجابة

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

اقتباس

حاليا الكود الافضل موجود و مختار :افضل اجابة

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

ما جهله السائل والمشرف أن هناك حلان، حل أساسي وهو تنقيح (تصحيح) الكود الأساس الذي أتى به السائل والأخر (وسيلة) حل مفترح صممته بعد إضافة ثلاثة أعمدة إضافية وطلبت من السائل تجربة النتائج لأنه تعثر في شرح مطلبه بالشكل الصحيح وكان هذا الكود بمثابة وسيلة لاختبار مخرجات الكود الأصل، وطبعا لا يمنع من استخدام فكرة الاختبار كحل بديل عند الرغبة.
 

أشكرك على تجاوبك والتكرم بالرد.

[AbuuAhmed]

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

Stock123_03.xlsm