Sub New ()
Dim AW As Window
    Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String
   Path = ThisWorkbook.Path & "\"
   Application.DisplayAlerts = False
       Set AW = ActiveWindow
    For Each s In AW.SelectedSheets
        Set TempWindow = AW.NewWindow
        s.Copy
        TempWindow.Close
   CellValue = Range("N8")
   FinalFileName = Path & CellValue
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
   Application.DisplayAlerts = True
    Next
           For Each ws In ActiveWorkbook.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next ws
    End Sub

=@ЕСЛИ(СМЕЩ(T18;-1;0)=T18;нумер(ЕСЛИ(S18="заголовок";1;2));1)

Sub Убрать_ошибку()
Range("O19:O20").Replace What:="+#REF!", Replacement:=""
Range("O19:O20").Replace What:="=#REF!", Replacement:="="
Range("O19:O20").Replace What:="=+", Replacement:="="
End Sub

Sub Sortirovka()
Range("A4:E12").Sort Key1:=Range("D4"), Order1:=xlAscending, Key2:=Range("B4"), Order2:=xlAscending, Key3:=Range("A4"), Order3:=xlAscending, Header:=xlYes
End Sub

Sub Sortirovka()
Range("A4:E12").Sort Key1:=Range("D4"), Order1:=xlAscending, Header:=xlYes
Range("A4:E12").Sort Key1:=Range("B4"), Order1:=xlAscending, Header:=xlYes
Range("A4:E12").Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlYes
End Sub

=ЕСЛИ(МИН(ЕСЛИ((Col_1=A2);Col_2;""))=0;"";МИН(ЕСЛИ((Col_1=A2);Col_2;"")))

Function Replace_symbols(ByVal txt As String) As String
    st$ = "~!@/\#$%^&*|`"""
    For i% = 1 To Len(st$)
        txt = Replace(txt, Mid(st$, i, 1), "-")
    Next
    Replace_symbols = txt
End Function

Sub Find()
MsgBox Range("D21:D157").Find("*яблок*").Row
End Sub

Worksheets(2).Activate
  Range("A1:E14").Calculate
  Range("A1:E28").Activate
     Dim smallrng As Range
     For Each smallrng In Selection.Areas
     smallrng.Value = smallrng.Value
     Next smallrng
  Range("A2").Select
  ActiveWindow.ScrollRow = 1
Worksheets(1).Activate

    With Worksheets(2)
     .Range("A1:E28").Activate
...
    End With.

Sub Разбить_по_файлам_ИЗМ()    
Dim oDic As Object, oFSO As Object    
Dim arrData(), arrSeparateItems()    
Dim TempWb As Workbook    
Dim sFolderPath As String, sFullFileName As String    
Dim LastRow As Long, i As Long, n As Long    
Dim RngData As Range, FilteredRng As Range        
If MsgBox("Разбить по файлам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub        
sFolderPath = ThisWorkbook.Path & "\" 'здесь укажите путь для сохранения файлов      
Application.ScreenUpdating = False       
Set oFSO = CreateObject("Scripting.FileSystemObject")    
Set oDic = CreateObject("Scripting.Dictionary")       
Dim shSource As Worksheet    
Set shSource = ActiveSheet       
Dim Application_Calculation As XlCalculation    
Application_Calculation = Application.Calculation   
Application.Calculation = xlCalculationManual       
With shSource              
If .FilterMode = True Then .ShowAllData        
LastRow = .Cells(.Rows.Count, 12).End(xlUp).Row        
arrData = .Range("T1:T" & LastRow).Value 'столбец, где нужно найти уникальные значения        
Set RngData = .Range("A1").CurrentRegion    
End With       
For i = 21 To UBound(arrData)        
If Not oDic.Exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), 0&    
Next i       
arrSeparateItems() = oDic.Keys       
For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)        
shSource.Copy

 



ХОТЕЛОСЬ БЫ СЮДА СКОПИРОВАТЬ ЕЩЕ ЛИСТ "Новый лист", КОТОРЫЙ СОДЕРЖИТСЯ В ИСХОДНОЙ КНИГЕ      






Set TempWb = ActiveWorkbook 
...ОПРЕДЕЛЕННЫЕ ДЕЙСТВИЯ С ЛИСТОМ, СКОПИРОВАННЫМ В ТЕКУЩУЮ КНИГУ... 
ActiveSheet.name = arrSeparateItems(n)         
sFullFileName = sFolderPath & arrSeparateItems(n) & ".xlsx"        
If oFSO.FileExists(sFullFileName) Then oFSO.Deletefile (sFullFileName)        
TempWb.SaveAs sFullFileName, FileFormat:=xlOpenXMLWorkbook 'XLSX        
TempWb.Close SaveChanges:=False    
Next n       
With ActiveSheet        
If .FilterMode = True Then .ShowAllData    
End With      
Application.Calculation = Application_Calculation    
Application.ScreenUpdating = True    
MsgBox "Файлы сохранены в " & sFolderPath, vbInformation, "Конец"
End Sub

Sheets(Array(Новый лист", ТЕКУЩИЙ ЛИСТ ЗАДАННЫЙ СЕЙЧАС КАК ShSourse)).Copy

        Set TempWb = Workbooks.Add
        With TempWb.Worksheets(1)
            FilteredRng.Copy .Range("A1")
        End With

If Selection.Row < 6 Or Selection.Row > 35 Then
MsgBox "Хотя бы одна ячейка ВНЕ диапазона строк 6..35"
Else
MsgBox "Выделенные ячейки ВНУТРИ диапазона строк 6..35"
End If
End Sub

Sub Add_Rows()
Dim r As Range
Dim yr As Long
t = Selection.Row
For Each r In Selection.Rows
yr = r.Row
   Range("D" & yr & ":U31").Copy
   Range("D" & yr + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
  Range("D" & yr & ":U" & yr).ClearContents
Next r
Range("D" & t).Select
End Sub

Sub Delete_Rows()
Dim r As Range
Dim yr As Long
t = Selection.Row
For Each r In Selection.Rows
yr = r.Row
   Range("D" & yr + 1 & ":U31").Copy
   Range("D" & yr).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Next r
Range("D" & t).Select
End Sub

Sub Макросстроки()
For Each r In Selection.Rows
r = Selection.Row
With Rows(r)
   Range("D" & r & ":U" & 29).Copy
   Range("D" & r + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
   Range("D" & r & ":U" & r).ClearContents
End With
Next r
End Sub

Function ConcatUniq(xRg As Range, xChar As String) As String
    Dim xCell As Range
    Dim xDic As Object
    Set xDic = CreateObject("Scripting.Dictionary")
    For Each xCell In xRg
        xDic(xCell.Value) = Empty
    Next
    ConcatUniq = Join$(xDic.Keys, xChar)
    Set xDic = Nothing
End Function

 Range("A33", Cells(Rows.Count, 7).End(xlUp)).Select
  Selection.Rows.AutoFit

[Безусловный код];
If {Текст документа содержит сочетание "ОПРЕДЕЛЕННОЕ СЛОВОСОЧЕТАНИЕ"} then  [Код выполняемый по условию]
Else {Конец}