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

[رحااال]

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

يوجد لدي قائمة أرقام جوالات بالآلاف ..

ويوجد لدي (قائمة أرقام) موجودين في القائمة أرغب بإزالتهم من القائمة

أريد أن أقول للإكسل أو قوقل شيت إحذف هذه القائمة، يعني القائمة الرئيسية اذا كانت تحتوي على أي رقم من هذه الأرقام فاحذفه

ويفضل أن تكون ورقة (sheet) أقوم بتحديثها دورياً بحيث أي رقم أضيفه لهذا العمود داخل الشيت يقوم بحذفه من القائمة الرئيسية الاساسية

فكيف هي الطريقة؟

[كمال على طارق]

وعليكم السلام-تفضل هذا الفيديو  بما انك لم تقم برفع ملف فبه طلبك

 

 

[محمد هشام.]

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

ادن انفترض اننا لدينا ورقتين الاولى باسم الرئيسية والثانية باسم استثناءات 

القائمة الرئيسية للارقام على ورقة الرئيسية بداية من الخلية A3 الى غاية A10000  (يمكنك تعديلها بما يناسبك)

قائمة الارقام المرغوب إزالتها موجودة في ورقة إستثناءات بداية من الخلية A2 الى غاية A10000 (يمكنك تعديلها بما يناسبك)

مكان استخراج الأرقام بعد إزالة العدم مرغوب بها هو العمود B 

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

ورقة الرئيسية الخلية B3  

=IF(ISNUMBER(MATCH(A3,'استثناءات '!$A$2:$A$10000,0)), "", A3)

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

=IFERROR(INDEX($B$3:$B$10000,MATCH(0,COUNTIF(D2:$D$2,$B$3:$B$10000)+(COUNTIF($B$3:$B$10000,$B$3:$B$10000)<>1),0)),"")

اما في حالة استخدامك للنسخ الحديثة وهدا أفضل دائما 

يمكنك استخدام احدى المعادلات التالية 

=FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (LEN(الرئيسية!A3:A10000) > 0))

او 

=FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (الرئيسية!A3:A10000 <> 0))

 كما في المثال المرفق

 

phone_numbers.xlsx

 

في حالة الرغبة باستخدام الاكواد يمكنك استخدام هدا 

Sub Extract_the_main()
    Dim i&, b&, n&, xMatch As Boolean
    Dim OneRng1 As Variant, OneRng2 As Variant
    Dim Cnt() As Variant, tmp As Object
    Dim dest As Worksheet: Set dest = Sheets("الرئيسية")
    Dim WS As Worksheet: Set WS = Sheets("استثناءات")

    OneRng1 = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Value
    OneRng2 = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).Value
    
    Set tmp = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(OneRng2, 1)
        If Not IsEmpty(OneRng2(i, 1)) And Not tmp.exists(OneRng2(i, 1)) Then
            tmp.Add OneRng2(i, 1), True
        End If
    Next i
    
    xMatch = False
    ReDim Cnt(1 To UBound(OneRng1, 1), 1 To 1)
    b = 1
    n = 0
    For i = 1 To UBound(OneRng1, 1)
        If Not IsEmpty(OneRng1(i, 1)) Then
            If tmp.exists(OneRng1(i, 1)) Then
                xMatch = True
            ElseIf OneRng1(i, 1) <> 0 Then
                Cnt(b, 1) = OneRng1(i, 1)
                b = b + 1
                n = n + 1
            End If
        End If
    Next i
    
    If Not xMatch Or n = 0 Then
        MsgBox "لم يتم العثور على أي تطابق بين البيانات", vbExclamation, "نتائج التصفية"
        Exit Sub
    End If

    dest.Range("C2:C" & dest.Rows.Count).ClearContents
    If b > 1 Then
        dest.Range("C2").Resize(b - 1, 1).Value = Cnt
    End If
    
    MsgBox "تم تصفية البيانات بنجاح" & vbCrLf & "عدد الأرقام المصفاة: " & n, vbInformation, "ورقة " & dest.Name
End Sub

 

مع امكانية النسخ لنفس الورقة ( الرئيسية ) او ورقة مغايرة في المرفق التالي 

 

 

 

 

phone_numbers vba.xlsb

تم تعديل أغسطس 25, 2024 بواسطه محمد هشام.

[أ / محمد صالح]

بارك الله لك أستاذ محمد

وهذا جهدي المتواضع في كود يحذف الموجود في قائمة الاستثناءات ويبقي غير الموجود وفي نفس العمود

Sub FilterUniqueItems()
    Dim rngA As Range, rngB As Range, cell As Range
    Dim dict As Object, outputRow As Long

    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الرئيسية")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("استثناءات")

    Set rngA = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
    Set rngB = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row)
    Set dict = CreateObject("Scripting.Dictionary")

    For Each cell In rngB
        dict(cell.Value) = 1
    Next cell

    outputRow = 1
    For Each cell In rngA
        If Not dict.exists(cell.Value) Then
            ws.Cells(outputRow, "A").Value = cell.Value
            outputRow = outputRow + 1
        End If
    Next cell

    ws.Range("A" & outputRow & ":A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
MsgBox "Done by mr-mas.com",,"M.A.S"
End Sub

بالتوفيق للجميع

[محمد هشام.]

بارك الله فيك استاد  @أ / محمد صالح كود جميل يمكننا استخدامه في حالة عدم الرغبة بالاحتفاظ بالارقام على القائمة الرئيسية  الاصلية