حذف نقس المادة من كل الأوراق ب زر أمر

Sub DelRows()

Dim ws As Worksheet, Sh As Worksheet

Dim StrDel As String, C As Range

Dim Lr As Long, Ls As Long

Dim NamShet As Variant, i As Integer

Set ws = Sheets("name_list")

Lr = ws.Range("A" & Rows.Count).End(xlUp).Row

StrDel = ActiveCell.Value

NamShet = ws.Range("A2:A" & Lr).Value

For i = 1 To UBound(NamShet, 1)

Set Sh = Sheets(NamShet(i, 1))

Ls = Sh.Range("A" & Rows.Count).End(xlUp).Row

For Each C In Sh.Range("A2:S" & Ls)

If C.Value = StrDel Then

C.Resize(1, 3).Delete

End If

Next

Next

End Sub

Dim wb As Workbook

    Dim xPro As VBIDE.VBProject

    Dim xCom As VBIDE.VBComponent

    Dim xMod As VBIDE.CodeModule

    Dim xLine As Long

    Set wb = ThisWorkbook

    With wb

        Set xPro = .VBProject

        Set xCom = xPro.VBComponents(ActiveSheet.CodeName)

        Set xMod = xCom.CodeModule

        With xMod

         .DeleteLines 1, .CountOfLines

            xLine = .CreateEventProc("selectionChange", "Worksheet")

            xLine = xLine + 1

            .InsertLines xLine, "  on error resume next"

            xLine = xLine + 1

End With

End With

If Application.VBE.MainWindow.Visible = True Then

        Application.VBE.MainWindow.Visible = False

           End If

    End With

ActiveSheet.Range("a1").Select

With ALL

.Show

End With