كيف أتأكد أنه لايوجد خلايا مكررة؟

[رحااال]

إخواني عندي عمود اكسل كله ارقام جوالات 

أقوم بإزالة الأرقام المكررة عن طريق تحديد العمود ثم بيانات ثم ازالة التكرارات

 

لكن أتفاجأ أن الرسائل تصل للعملاء مرتين وعند العودة للجدول اجد أن هناك فعلاً ارقام مكررة أي أنه لم يتم إزالة التكرارات كلها فكيف أتأكد من ذلك حتى لا أتسبب بإزعاج وإحراج مع العميل؟

[أبوأحـمـد]

ربما بعض الأرقام بالمفتاح الدولي وبعضها بدونه

وللتأكد دعنا نجرب مثلا آخر 6 أرقام من خلال هذه المعادلة

على فرض أن الأرقام في العمود A1 ونازل ضع هذه المعادلة بالخلية B1 اسحب لأسفل

ناتج المعادلة الطبيعي 1 وما زاد هو عدد التكرار

=SUMPRODUCT(((RIGHT($A1:$A$1;6))=(RIGHT(A1;6)))*1)

 

[ابا اسماعيل]

بعد اذن الاخ أبوأحـمـد

جرب هذا الكود سيقوم بالتحقق من وجود القيم المكررة في الأعمدة A و B و C وسيقوم بسحب القيم المكررة إلى الأسفل

 

Private Sub RemoveDuplicatesAndFillDown()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim colRangeA As Range
    Dim colRangeB As Range
    Dim colRangeC As Range
    Dim cell As Range

    ' تعيين الورقة المستهدفة
    Set ws = ThisWorkbook.Worksheets("التكويد")
    
    ' العثور على آخر صف غير فارغ في العمود C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' تعيين نطاقات الأعمدة A و B و C
    Set colRangeA = ws.Range("A2:A" & lastRow)
    Set colRangeB = ws.Range("B2:B" & lastRow)
    Set colRangeC = ws.Range("C2:C" & lastRow)
    
    ' إلغاء تنسيق الخلايا المحددة
    colRangeA.NumberFormat = "General"
    colRangeB.NumberFormat = "General"
    colRangeC.NumberFormat = "General"
    
    ' إزالة القيم المكررة وسحب القيم إلى الأسفل في الأعمدة A و B
    For Each cell In colRangeA
        If Application.WorksheetFunction.CountIf(colRangeA, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeB
        If Application.WorksheetFunction.CountIf(colRangeB, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeC
        If Application.WorksheetFunction.CountIf(colRangeC, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
End Sub

 

تم تعديل أغسطس 7, 2023 بواسطه ابا اسماعيل

[أبومروان]

بعد اذان الاستاذ @أبوأحـمـد @ابا اسماعيل

 

لإثراء الموضوع

يمكنك الاستفاده

 

[رحااال]

في 7‏/8‏/2023 at 08:19, أبوأحـمـد said:

ربما بعض الأرقام بالمفتاح الدولي وبعضها بدونه

ناتج المعادلة الطبيعي 1 وما زاد هو عدد التكرار

أشكرك أخي الفاضل، لا التكرار بعد التأكد أنها جميعا مطابقة بدون مفتاح دولي

استخدمت نفس الطريقة وظهر لي التكرار بعضها 2 وبعضها 3

الاشكال كيف أزيل هذه التكرارات اذا كان العمود كبير؟ بالآلاف

في 7‏/8‏/2023 at 11:16, ابا اسماعيل said:

بعد اذن الاخ أبوأحـمـد

جرب هذا الكود سيقوم بالتحقق من وجود القيم المكررة في الأعمدة A و B و C وسيقوم بسحب القيم المكررة إلى الأسفل

 

Private Sub RemoveDuplicatesAndFillDown()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim colRangeA As Range
    Dim colRangeB As Range
    Dim colRangeC As Range
    Dim cell As Range

    ' تعيين الورقة المستهدفة
    Set ws = ThisWorkbook.Worksheets("التكويد")
    
    ' العثور على آخر صف غير فارغ في العمود C
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    ' تعيين نطاقات الأعمدة A و B و C
    Set colRangeA = ws.Range("A2:A" & lastRow)
    Set colRangeB = ws.Range("B2:B" & lastRow)
    Set colRangeC = ws.Range("C2:C" & lastRow)
    
    ' إلغاء تنسيق الخلايا المحددة
    colRangeA.NumberFormat = "General"
    colRangeB.NumberFormat = "General"
    colRangeC.NumberFormat = "General"
    
    ' إزالة القيم المكررة وسحب القيم إلى الأسفل في الأعمدة A و B
    For Each cell In colRangeA
        If Application.WorksheetFunction.CountIf(colRangeA, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeB
        If Application.WorksheetFunction.CountIf(colRangeB, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
    
    For Each cell In colRangeC
        If Application.WorksheetFunction.CountIf(colRangeC, cell.Value) > 1 Then
            cell.Offset(1, 0).Resize(lastRow - cell.Row).Value = cell.Value
        End If
    Next cell
End Sub

 

 

ممتاز لكن السؤال كيف أطبق هذا الكود وأين أضعه؟

هل أضعه في خلية واحدة مثلاً؟

السؤال الذي يطرح نفسه ما هو فائدة أيقونة إزالة التكرارات إذن؟ 

اذا كانت لا تقوم بإزالة التكرارات؟

لاحظوا هذه الرسالة تتكرر في كل مرة أقوم بالضغط على "إزالة التكرارات" !!!

والعدد يبقى كما هو 

[أبوأحـمـد]

13 ساعات مضت, رحااال said:

أشكرك أخي الفاضل، لا التكرار بعد التأكد أنها جميعا مطابقة بدون مفتاح دولي

استخدمت نفس الطريقة وظهر لي التكرار بعضها 2 وبعضها 3

الاشكال كيف أزيل هذه التكرارات اذا كان العمود كبير؟ بالآلاف

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

[رحااال]

9 ساعات مضت, أبوأحـمـد said:

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

1- عملت فرز لكن هل الفرز يكون للأرقام 1 . 2 والا للارقام الاساسية كيف اسوي فرز بحيث يكون ارتباط بين الرقم والنتيجة

2- هل الارقام 2 يعني ان الرقم موجود مرتين و3 يعني 3 مرات وهكذا؟   لأنني بحثت عن 3 ووجدته مرتين فقط و4 كذلك

 

[أبوأحـمـد]

نعم صحيح 1= لا يوجد تكرار 

وهذا تعديل للمعادلة لزيادة التأكد

تم إضافة TRIM لحذف الفراغات

 

=SUMPRODUCT(((TRIM(RIGHT($A1:$A$1;6)))=TRIM((RIGHT(A1;6))))*1)

 

[رحااال]

6 ساعات مضت, أبوأحـمـد said:

نعم صحيح 1= لا يوجد تكرار 

وهذا تعديل للمعادلة لزيادة التأكد

تم إضافة TRIM لحذف الفراغات

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

فكيف اسوي سورت بحيث يكون كل نتيجة مرتبط بالرقم 

=SUMPRODUCT(((TRIM(RIGHT($A1:$A$1;6)))=TRIM((RIGHT(A1;6))))*1)

 

 

[أبوأحـمـد]

14 دقائق مضت, رحااال said:

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

 

لحل المشكلة انسخ العمود اللي فيه معادلة ثم إلصقه كقيم