Sub Макрос2()
    Cells.Select
    Range("I1").Activate
    Selection.ClearContents
    Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Sheets("БАЗА").Select
    Cells.Select
    Range("I1").Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
 
    Dim sSubStr As String 
    Dim lCol As Long 
    Dim lLastRow As Long, li As Long
    Dim arr   
    sSubStr = ""
    
    lCol = 26
    If lCol = 0 Then Exit Sub
 
    lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    arr = Cells(1, lCol).Resize(lLastRow).Value
 
    Application.ScreenUpdating = 0
    Dim rr As Range
    For li = 2 To lLastRow 
        If CStr(arr(li, 1)) <> sSubStr Then 
                Set rr = Cells(li, 1)
            Else
                Set rr = Union(rr, Cells(li, 1))
            End If
        End If
    Next li
    If Not rr Is Nothing Then rr.EntireRow.Delete
    Application.ScreenUpdating = 1
 End Sub