حذف الصفوف التي تحتوي على كلمات معينة فى العمود المحدد

[ابو مارفن]

Sub Test()
    Dim Cel As Range
    For Each Cel In Sheet2.Range("B1:B" & Sheet1.Cells(Rows.Count, "B").End(xlUp).Row)
        If Cel.Value = "كلية التربية" Then Cel.EntireRow.Delete
    Next Cel
End Sub

السلام عليكم المطلوب التعديل على الكود لحذف الصفوف التي تحتوي على كلية التربية ومعهد عالي في العمود B مع العلم عدد الصفوف كثيره في الملف

مسح صفوف معينة بناء على قيمتها.xlsx

[أبوعيد]

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

جرب هذا الملف

 

تعديل مسح صفوف.xlsm

تم تعديل مارس 4 بواسطه أبوعيد
تم تعديل الكود لزيادة كفاءته

[محمد هشام.]

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

Sub test()
    Dim CrWS As Worksheet
    Dim lastRow As Long, tmps As Variant
    
    tmps = Array("=*كلية التربية*", "=*معهد عالي*")
    
    Set CrWS = Sheets("ورقة1")
    
    lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
    If lastRow < 2 Then Exit Sub
    
    Application.ScreenUpdating = False
    With CrWS.Range("B1:B" & lastRow)
        .AutoFilter Field:=1, Criteria1:=tmps, Operator:=xlFilterValues
    End With
    On Error Resume Next
    CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    On Error GoTo 0
    
    CrWS.AutoFilterMode = False
    
    Application.ScreenUpdating = True
End Sub

 

[محمد هشام.]

إدا كنت ترغب في إستخدام الإقتراح المقدم من الأستاد  @أبوعيد

يمكنك تجربة هدا 

Public Property Get CrWS() As Worksheet
    Set CrWS = Sheets("ورقة1")
End Property

Private Sub UserForm_Initialize()
    Dim Tbl As Object, c As Range, temp As Variant, lastRow As Long
    Set Tbl = CreateObject("Scripting.Dictionary")
    lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row
    
    If lastRow > 1 Then
        For Each c In CrWS.Range("B2:B" & lastRow)
            If c.Value <> "" Then Tbl.Item(c.Value) = c.Value
        Next c
    End If
    
    If Tbl.Count > 0 Then
        temp = Tbl.items
        Me.ComboBox1.List = temp
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim lastRow As Long, ky As String
    If Me.ComboBox1.Value <> "" Then
    ky = "=*" & Me.ComboBox1.Value & "*"
    lastRow = CrWS.Cells(CrWS.Rows.Count, "B").End(xlUp).Row

    If lastRow < 2 Then Exit Sub

    Application.ScreenUpdating = False
    With CrWS.Range("B1:B" & lastRow)
        .AutoFilter Field:=1, Criteria1:=ky
    End With

    On Error Resume Next
    CrWS.Range("A2:C" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    On Error GoTo 0
    CrWS.AutoFilterMode = False
    Application.ScreenUpdating = True
    Unload Me
    End If
End Sub

 

 

مسح صفوف معينة بناء على قيمتها v2.xlsb

تم تعديل مارس 4 بواسطه محمد هشام.

[ابو مارفن]

مشكور لجهودكم اساتذتنا الاعزاء الله يبارك بيكم 

ويجعلها في ميزان حسناتكم 

تحياتي لكم من القلب