قائمة إزالة

[رحااال]

السلام عليكم

عندي ملف اكسل فيه ارقام لعملاء بعض العملاء يطلب ازالته من القائمة، أنشأت ورقة فيها قائمة يتم ازالتهم باستمرار

هل يمكن أن تكون هذه القائمة مربوطة تلقائياً حيث أي رقم اضيفه يتم حذفه من القائمة تلقائياً؟

(لو كان على شكل عمود في نفس الصفحة بيكون افضل من ورقة مستقلة)   

 

الملف مرفق

officena.xlsx

[عبدالله بشير عبدالله]

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

منذ ساعه, رحااال said:

(لو كان على شكل عمود في نفس الصفحة بيكون افضل من ورقة مستقلة)   

 

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

الكود 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim foundCell As Range
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim deleteRow As Long
    
    Set ws = Me
    Set rng = ws.Range("A:A")
    
    If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
        Application.EnableEvents = False
        
        For Each cell In Intersect(Target, Me.Range("E:E"))
            If cell.Value <> "" Then
                Set foundCell = rng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not foundCell Is Nothing Then
                    deleteRow = foundCell.Row
                    foundCell.Delete xlShiftUp
                Else
                    MsgBox "رقم العميل " & cell.Value & " غير موجود في قائمةالعملاء .", vbExclamation, "رقم غير موجود"
                End If
            End If
        Next cell

        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        Set rng = ws.Range("A2:A" & lastRow)
        rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo

        Application.EnableEvents = True
    End If
End Sub

الملف

officena.xlsb

[أبومروان]

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

بعد اذن استاذي @عبدالله بشير عبدالله حل اخر بالمعادلات

=IF(ISNA(VLOOKUP(A1, 'إزالة من القائمة'!A:A, 1, FALSE)), "إبقاء", "إزالة")

 

[رحااال]

4 ساعات مضت, عبدالله بشير عبدالله said:

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

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

الكود 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim foundCell As Range
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim deleteRow As Long
    
    Set ws = Me
    Set rng = ws.Range("A:A")
    
    If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
        Application.EnableEvents = False
        
        For Each cell In Intersect(Target, Me.Range("E:E"))
            If cell.Value <> "" Then
                Set foundCell = rng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not foundCell Is Nothing Then
                    deleteRow = foundCell.Row
                    foundCell.Delete xlShiftUp
                Else
                    MsgBox "رقم العميل " & cell.Value & " غير موجود في قائمةالعملاء .", vbExclamation, "رقم غير موجود"
                End If
            End If
        Next cell

        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        Set rng = ws.Range("A2:A" & lastRow)
        rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo

        Application.EnableEvents = True
    End If
End Sub

الملف

officena.xlsb 16.12 kB · 2 downloads

 

 

 

[عبدالله بشير عبدالله]

لا اعلم ما السبب  حملت الملف ويعمل 

سارقع الملف مرة اخرى

اخبرني بالنتيجة

ازالة1.xlsm

[رحااال]

8 ساعات مضت, عبدالله بشير عبدالله said:

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

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

الكود 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cell As Range
    Dim foundCell As Range
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long
    Dim deleteRow As Long
    
    Set ws = Me
    Set rng = ws.Range("A:A")
    
    If Not Intersect(Target, Me.Range("E:E")) Is Nothing Then
        Application.EnableEvents = False
        
        For Each cell In Intersect(Target, Me.Range("E:E"))
            If cell.Value <> "" Then
                Set foundCell = rng.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not foundCell Is Nothing Then
                    deleteRow = foundCell.Row
                    foundCell.Delete xlShiftUp
                Else
                    MsgBox "رقم العميل " & cell.Value & " غير موجود في قائمةالعملاء .", vbExclamation, "رقم غير موجود"
                End If
            End If
        Next cell

        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        Set rng = ws.Range("A2:A" & lastRow)
        rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo

        Application.EnableEvents = True
    End If
End Sub

الملف

officena.xlsb 16.12 kB · 2 downloads

 

نفس المشكلة، ألاحظ أن الامتداد يختلف عن ملفات الاكسل عندي، لو استطعت أن تحفظها بامتداد اكسل الطبيعي