Удаление ненужных строк в Excel

[djbub14]

Есть таблица. Около 10 столбцов и очень много строк. В строках идет примерно такое содержимое в столбце А:

текст1@дополнение1
текст2@дополнение2
текст3@дополнение3

У меня есть текстовичок, где написано следующее

текст1
текст28
текст3

и т.п. Т.е. те части из столбца А, которые идут до символа "@". Есть ли фильтр или макрос, чтобы я могу загрузить текстовичок в эксель или внести через буфер этот список и после он бы найдя в столбце А эти данные удалял бы строчку полностью?

[doober]

можно так

Sub Kill_Email()
Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim s As String
Set Txt = oFSO.OpenTextFile("C:\11.txt", 1, False)  'Путь к текстовику
 With Sheets("Лист1") ' Имя вашего листа
On Error Resume Next
Do
    s = Txt.ReadLine
   Dim rng As Range
   Set rng = .Columns(1).Find(Trim(s) & "@")
   If Not rng Is Nothing Then
  .Range(rng.AddressLocal).Interior.Color = 255
   End If
Loop While Err = 0
   Dim ra As Range, cell As Range
    Set ra = .UsedRange.Columns(1)
   For Each cell In ra.Cells
        If cell.Interior.Color = 255 Then .Rows(cell.Row).Delete
       Next cell
     End With
    Txt.Close
     Set oFSO = Nothing
       
End Sub

[IgorGO]

или так:

Sub DelSameAddress()
  Dim fn As String, adr As String, hm As Long, r As Long
  fn = ThisWorkbook.Path & "\address.txt"
  hm = 0
  Open fn For Input As #1
    Do While Not EOF(1)
      Input #1, adr
      adr = adr & "@*"
      s = "  "
      If WorksheetFunction.CountIf([a:a], adr) > 0 Then
        For r = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
          If Cells(r, 1) Like adr Then
            Rows(r).Delete
            s = s & "I"
            hm = hm + 1
            Application.StatusBar = "Deleted " & adr & s
          End If
        Next
      End If
    Loop
  Close #1
  Application.StatusBar = False
  MsgBox "Done." & Chr(10) & hm & " rows DELETED"
End Sub

зупускать макрос с листа со списком адресов.
файл с адресами, которые надо удалить должен называться address.txt и находиться в той же папке, что и обрабатываемый файл.

[SAS888]

Можно сделать и более рационально, без перебора ячеек столбца:

Sub Main()
    Dim i As Long, p As String, x As Range, a: Application.ScreenUpdating = False
    p = "D:\Temp\11.txt" 'Путь к текстовику
    a = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(p, 1, False).ReadAll, vbCrLf)
    With Sheets("Лист1")
        For i = LBound(a) To UBound(a)
            Set x = .[A:A].Find(a(i) & "@")
            If Not x Is Nothing Then
                .[A:A].ColumnDifferences(x).EntireRow.Hidden = True
                Intersect(.UsedRange, .[A:A].SpecialCells(xlCellTypeVisible)).EntireRow.Delete
                Rows.Hidden = False
    End If: Next: End With
End Sub