حذف بيانات الفاتورة المكررة

[أبو إيمان]

السلام عليكم

في المرفق كود احتاجه ويمثل أيضا حل لجزء داخل موضوع من موضوعات المنتدى

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

وشكرا

 

 

حذف الفواتير المكررة.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

تفضل اخي جرب

Sub Supprimer_la_ligne_en_double_B()
Dim Rng As Range
Dim X As Long
Set Rng = Range("B2", Range("B" & Rows.Count).End(xlUp))
X = Rng.Rows.Count
For X = X To 1 Step -1
    With Rng.Cells(X, 1)
        If WorksheetFunction.CountIf(Rng, .Value) > 1 Then
            .EntireRow.Delete
        End If
    End With
Next X
End Sub

 

حذف الفواتير المكررة.xlsm

[أبو إيمان]

الاستاذ محمد جزاكم الله خيرا

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

حضرتك لاحظ أن الفاتورة 325 تحتوي على عنصرين  الفاتورة 330 تحتوي على ثلاث عناصر وعند تطبيق كودك يتم حذف عنصر واحد فقط والمطلوب حذف جميع عناصر الفاتورة 

وشكرا

 

[أبو إيمان]

الكود التالي يحذف جميع بيانات الفاتورة المحدد 

Application.ScreenUpdating = False
On Error Resume Next
Dim XL As String
XL = 325
    
    LR = [B10000].End(xlUp).Row
        For R = 2 To LR
            x = Cells(R, 2).Value
            If x = XL Then
            
            If R <> LR Then n_lr = .Cells(R, 2).End(xlDown).Row - 1: GoTo 20
            n_lr = [H10000].End(xlUp).Row
            End If
        Next R
20          Range("D" & R & ":H" & n_lr).EntireRow.Delete Shift:=xlUp
 
End With

 

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

[محمد هشام.]

Sub test2()
lr = [b10000].End(xlUp).Row
Range("B2:b" & lr).CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
End Sub

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

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

تم تعديل فبراير 17, 2023 بواسطه Mohamed Hicham

[أبو إيمان]

2 ساعات مضت, Mohamed Hicham said:

جملة الفاتورة المحددة

أقصد الفاتورة  المكتوبة 325  ولكي يتضح الأمر قمت بإرفاق الملف التالي ربما يكن الأمر أكثر وضوحا واعتذر اذا لم استطع التوضيح 

 

حذف الفواتير المكررة 002.xlsm

[محي الدين ابو البشر]

السلام عليكم

ربما يكون المطلوب حسب ما فهمت

Sub test()
Dim r As Range
Application.ScreenUpdating = False
For Each r In Columns(2).SpecialCells(4).Areas
        Range(r.Address) = r(0)
        Range(r.Address).Offset(, 1) = r(0).Offset(, 1)
        r.Offset(-1).EntireRow.Delete
Next
 Application.ScreenUpdating = True
End Sub

Or
Sub test()
Dim r As Range
Application.ScreenUpdating = False
For Each r In Columns(2).SpecialCells(4).Areas
        Range(r.Address) = r(0)
        Range(r.Address).Offset(, 1) = r(0).Offset(, 1)
        r.Offset(-1).Resize(, 7).Delete
 Next
 Application.ScreenUpdating = True
End Sub

تم تعديل فبراير 18, 2023 بواسطه محي الدين ابو البشر

[أبو إيمان]

الاستاذ محي الدين أشكر مرورك الكريم والشكر موصول للاستاذ محمد هشام 

المرفق التالي نفس المرفق في المشاركة السابقة لرد الاستاذ محي الدين 

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

** عند الضغط على الزر حذف فاتورة يطلب ادخال رقم الفاتورة وحذفها بجميع البيانات المرتبطة بها 

 

المطلوب : عند الضغط على الزر يبحث عن ارقام الفواتير المكررة ويحذف الفاتورة بجميع بياناتها والابقاء على واحدة فقط

 

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

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

 

 

 

حذف الفواتير المكررة 003.xlsm

[محي الدين ابو البشر]

وماذا عن هذا؟

Sub test2()
Dim xl
Dim r
xl = InputBox("ادخل رقم الفاتورالمراد حذفها ", "معرض خيري  ..  حذف فاتورة  .. //!!")
Set r = Columns(2).Find(xl, , , 1)
If Not r Is Nothing Then
    Range(r, r.End(xlDown)).Resize(Range(r, r.End(xlDown)).Cells.Count - 1, 7).Delete
Else
    MsgBox "الفاتورة رقم( " & xl & ")غير موجودة "
End If
End Sub

 

[أبو إيمان]

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

 

المطلوب 

عند تنفيذ الكود يبحث  في أرقام الفواتير وإئا وجد تكرار ( Duplicate ) يحذف بيانات الفاتورةالمكررة 

دون الحاجة إلى ادخال الرقم يدويا

تم تعديل فبراير 19, 2023 بواسطه أبو إيمان