Range("H1").Select    ActiveSheet.Range("$G$1:$H$46").AutoFilter Field:=2, Criteria1:="=*заме*", _
        Operator:=xlAnd
 ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "Замена модема"
    Selection.FillDown

Range("H1").Select
    ActiveSheet.Range("$G$1:$H$46").AutoFilter Field:=2, Criteria1:="=*заме*", _
        Operator:=xlAnd
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Замена модема"
    Range("G2").Select
    Selection.FillDown

ActiveCell.SpecialCells(xlLastCell).Select

Sub Кнопка()
Kill "D:\ВИДЕО\ТЭСТ.mp4"
End Sub

Sub СохранениеСТС()
Sheets("Павлодар".Select
If IsEmpty(Range("C1") = True Then
MsgBox "Первая строка пустая."
 Else
  End If
  
  If IsEmpty(Range("C2") = True Then
MsgBox "Вторая строка пустая."
 Else
  Dim x As Long, lr&, strArray
  Dim strWholeFile As String
    
lr = Cells(1, 1).End(xlDown).Row     'последняя строка
 
ReDim strArray(1 To lr)
  For x = 1 To lr - 1
    strWholeFile = strWholeFile & Cells(x, 3).Value & vbCrLf
  Next
  strWholeFile = strWholeFile & Cells(x, 3).Value ' special case w/o vbCrlf
    
  Dim ADOStream
  Set ADOStream = CreateObject("ADODB.Stream"
    
  With ADOStream
    .Open
    .Position = 0
    .Charset = "unicode"
    .WriteText strWholeFile
    .SaveToFile "C:\БЕГУШКИ ПАВЛОДАР\ПАВЛОДАРСТС.txt", 2 ' overwrite if exists
    .Close
  End With

  End If
End Sub

strWholeFile = strWholeFile & Cells(x, 1).Value & vbCrLf  Next
strWholeFile = strWholeFile & Cells(x, 1).Value ' special case w/o vbCrlf

SubCopy_File()
DimsFileName AsString,sNewFileName AsString
 
    sFileName="C:\WWW.xls"    'имя файла для копирования
    sNewFileName="D:\WWW.xls"    'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    IfDir(sFileName,16)=""ThenMsgBox"Нет такого файла",vbCritical,"Ошибка":ExitSub
    
    FileCopy sFileName,sNewFileName'копируем файл
    MsgBox"Файл скопирован",vbInformation,"www.excel-vba.ru"
EndSub

Sub СОХРАСТ()
Sheets("Астана".Select
Dim i As Long, s As String
i = Cells(1, 1).End(xlDown).Row 'последняя строка
ReDim arr(1 To i) As String
For i = 1 To UBound(arr)
arr(i) = Cells(i, 1)
Next i
s = Join(arr, vbCrLf)
Open "C:\Астана.txt" For Output As #1 'сохранение
Print #1, s
Close #1 End Sub

ActiveWorkbook.SaveAs Filename:= _
        "C:\Астана.txt" _
        , FileFormat:=xlUnicodeText, CreateBackup:=False

    Dim ra As Range, delra As Range
    Application.ScreenUpdating = False    ' отключаем обновление экрана

    ' ищем и удаляем строки, содержащие заданный текст
   ' (можно указать сколько угодно значений, и использовать подстановочные знаки)
   УдалятьСтрокиСТекстом = Array("ID ", "Шапка ", "Лицензия ", "(СЗ")

    ' перебираем все строки в используемом диапазоне листа
   For Each ra In ActiveSheet.UsedRange.Rows
        ' перебираем все фразы в массиве
       For Each word In УдалятьСтрокиСТекстом
            ' если в очередной строке листа найден искомый текст
           If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
                ' добавляем строку в диапазон для удаления
               If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
            End If
        Next word
    Next

    ' если подходящие строки найдены, то: (оставьте одну из 2 следующих строк)
   If Not delra Is Nothing Then delra.EntireRow.Hidden = True    ' скрываем их
   If Not delra Is Nothing Then delra.EntireRow.Delete    ' удаляем их

Sub Кнопка1_Щелчок()
Dim i As Long, s As String
i = Cells(1, 1).End(xlDown).Row     'последняя строка
ReDim arr(1 To i) As String
For i = 1 To UBound(arr)
    arr(i) = Cells(i, 1)
Next i
s = Join(arr, vbCrLf)
Open ThisWorkbook.Path & "\время.txt" For Output As #1      'сохранение
Print #1, s
Close #1
End Sub