Sub ActSheetSave()
    Dim wb As Workbook
    Dim FolderName As String
    Dim fname As String
    Dim mName As String
    Dim n As Variant
        
    Application.ScreenUpdating = False

    BookPath = ActiveWorkbook.Path
    If BookPath = "" Then
        MsgBox "Сохраните файл!"
        Exit Sub
    End If
         
            mName = Replace_symbols([C2&"_"&C3&"_"&C4&"_"&H2])
           
            ActiveSheet.Copy
            Set wb = ActiveWorkbook
            
     For Each n In wb.Names:
        On Error Resume Next
        n.Delete:
    Next
    
      'WorkbookLinks = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
        'If IsArray(WorkbookLinks) Then
            'For i = LBound(WorkbookLinks) To UBound(WorkbookLinks)
                'wb.BreakLink Name:=WorkbookLinks(i), Type:=xlLinkTypeExcelLinks
            'Next i
        'End If
                                  
    Application.DisplayAlerts = False
    fname = Application.GetSaveAsFilename(InitialFileName:=mName, _
                                          FileFilter:="Excel Files (*.xlsx), *.xlsx", _
                                          Title:="Сохранить файл")
    If VarType(fname) <> vbBoolean Then ActiveWorkbook.SaveAs fname
    Application.DisplayAlerts = True
            wb.Close False
    
   ActiveSheet.Select
      
End Sub

Sub SelectSheetsPrint()
    Dim a() As Integer, i As Integer, j As Integer
    ReDim a(1 To Sheets.Count) 
    j = 0 
        For i = 1 To Sheets.Count 
        If Sheets(i).Tab.ColorIndex = Sheets("Образец").Tab.ColorIndex Then
            j = j + 1 
            a(j) = Sheets(i).Index 
        End If
    Next
    ReDim Preserve a(1 To j) 
    Sheets(a).Select 
    Application.Dialogs(xlDialogPrint).Show
    Sheets("Оглавление").Select
End Sub

Sub ColorSheet()
For i = 1 To Sheets.Count
If Sheets(i).Tab.ColorIndex = 13 Then Sheets(i).PrintOut From:=1, To:=Sheets(i).PageSetup.Pages.Count
Next
End Sub

Sub ColorSheetDialog()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
If sh.Tab.ColorIndex = 13 Then sh.Select False
Next sh
Application.Dialogs(xlDialogPrint).Show
End Sub