Sub Style()
  Dim i As Byte, StrStart As Byte, StrStop As Byte, QtyEL As Byte, Str_arr() As Byte, coll As Variant
  Dim collSTL As New Collection, collSTL1 As New Collection, collSTL2 As New Collection, collSTL3 As New Collection, collSTL4 As New Collection, collSTL5 As New Collection
  Dim cSTL1 As Byte, cSTL2 As Byte, cSTL3 As Byte, cSTL4 As Byte, cSTL5 As Byte
    StrStart = 7
    StrStop = 17
    QtyEL = 1 + StrStop - StrStart
    ReDim Style_arr(1 To QtyEL)
    Style_arr = ActiveSheet.Range(Cells(StrStart, 4), Cells(StrStop, 4)).Value
    'Значения в столбце 4 для заполнения Style_arr:  "OOO 022", "OOO 022", "OOO 022", "OOO 022", "OOO 023", "OOO 023", "OOO 023", "EEE 511", "EEE 511", "FF 431", "FF 431"
    For i = 1 To QtyEL
        If Style_arr(i, 1) = Style_arr(1, 1) Then
            collSTL1.Add Style_arr(i, 1)
        Else
            If cSTL2 = 0 Then cSTL2 = i
            If Style_arr(i, 1) = Style_arr(cSTL2, 1) Then
                collSTL2.Add Style_arr(i, 1)
            Else
                If cSTL3 = 0 Then cSTL3 = i
                If Style_arr(i, 1) = Style_arr(cSTL3, 1) Then
                    collSTL3.Add Style_arr(i, 1)
                Else
                    If cSTL4 = 0 Then cSTL4 = i
                    If Style_arr(i, 1) = Style_arr(cSTL4, 1) Then
                        collSTL4.Add Style_arr(i, 1)
                    Else
                        If cSTL5 = 0 Then cSTL5 = i
                        If Style_arr(i, 1) = Style_arr(cSTL5, 1) Then collSTL5.Add Style_arr(i, 1)
                    End If
                End If
            End If
        End If
    Next i
    collSTL.Add collSTL1
    If collSTL2.Count > 0 Then collSTL.Add collSTL2
    If collSTL3.Count > 0 Then collSTL.Add collSTL3
    If collSTL4.Count > 0 Then collSTL.Add collSTL4
    If collSTL5.Count > 0 Then collSTL.Add collSTL5
For Each coll In collSTL
    'Обработка
Next coll
End Sub

Private Sub Rnm_Fail()
  Dim RnmFail$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
  ChDrive Left(ThisWorkbook.Path, 1)
  ChDir ThisWorkbook.Path
  AFLPath = ThisWorkbook.Path: If Right$(AFLPath, 1) <> "\" Then AFLPath = AFLPath & "\"
  RnmFail = Application.GetOpenFilename("Выберите фото (*.jpg),*.jpg", 1, "Выберите фото:  ")
  If Not RnmFail = "False" Then
    Name RnmFail As AFLPath & "111.jpg"
  End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub TEST_1()
    Dim Byf$
    Byf = "This is bold." & Chr(13) & "This is normal."
    SetClipBoardText Byf
End Sub
Function SetClipBoardText(ByVal Text As Variant) As Boolean
    SetClipBoardText = CreateObject("htmlfile").parentWindow.clipboardData.SetData("Text", Text)
End Function

Sub TEST_2()
    Dim Byf$
    Byf = "This is bold." & Chr(13) & "This is normal."
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .SetText Byf: .PutInClipboard
    End With
End Sub

<p><em><span style="font-family:Calibri;color: rgb(0, 41, 114);font-size:11pt;">Коллеги, Здравствуйте.</em></span></p>

Range("DRT_Str").Row + 1

Sub PDF_1()
''Работает, но только с видимыми листами, имена листов игнорит, считает с первого видимого.
    ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Test\file1.pdf", _
    From:=2, To:=5, OpenAfterPublish:=True
End Sub

Sub Скрыть()
''Работает, но так же выбрать 150 листов............!
    Sheets(Array("2", "3", "4", "5")).Activate
    ActiveWindow.SelectedSheets.Visible = False
End Sub
Sub Показать()
''Не работает...............?
    Sheets(Array("2", "3", "4", "5")).Activate
    ActiveWindow.SelectedSheets.Visible = True

    Sheets(Array("2", "3", "4", "5")).Visible = True
End Sub

Sub PDF_2()
''Работает только с видимыми, и выбрать тут 150 листов............
    Sheets(Array("Лист2", "Лист3", "Лист4", "Лист5")).Select
    Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\Test\file2.pdf", OpenAfterPublish:=True
End Sub

Sub PDF_3()
''Работает с одним листом, если лист видимый, Как выбрать 150 листов??????!
    FulName$ = "C:\Test\file3.pdf"
    ShNm$ = "Лист1"
    SavePDF ShNm, FulName
End Sub
Function SavePDF(ByVal ShNm As String, FulName As String)
Sheets(ShNm).ExportAsFixedFormat Type:=xlTypePDF, Filename:=FulName, Quality:=xlQualityMinimum _
    , IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Function

DialogSheets("MENU").Hide

MsgBox

Sub Test()
    'Чтоб работало, нужно в редакторе VBA во вкладке Tools опция References подключить Microsft Power Point Object Library
    On Error Resume Next
    ThisWorkbook.VBProject.References.AddFromFile Application.path & "\MSPPT.OLB"
    On Error GoTo 0
    Dim pp As New PowerPoint.Application
    With pp.Presentations.Open("Диск:\путь к файлу\???????.pptx")
        .ExportAsFixedFormat .path & "\test.pdf", 2&, 2&
        .Close
    End With
    If pp.Presentations.Count = 0 Then pp.Quit
    Set pp = Nothing
End Sub

Sub Test()
    Dim Inspector As Outlook.Inspector
    Set Inspector = Application.ActiveInspector()

    '1 фон письма - рисунок с диска
Inspector.CurrentItem.HTMLBody = "<head><meta charset=utf-8><title>background-image</title><style>" _
& "body {background-image: url(C:\imagesKYRH6AYS.jpg); /* Путь к фоновому изображению */" _
& "background-color: #efefef; /* Цвет фона */" _
& "}</style></head><body><p>Привет</p></body>"

    '2 пытался фоном письма сделать фон из стандартной темы Outlook "Геометрия"
Inspector.CurrentItem.HTMLBody = "<head><meta charset=utf-8><title>background-image</title><style>" _
& "body {background-image: url(image001.gif@01CD3469.D1EB1F70); /* Путь к фоновому изображению */" _
& "background-color: #efefef; /* Цвет фона */" _
& "}</style></head><body><p>Привет</p></body>"

    '3
Inspector.CurrentItem.HTMLBody = "<head><meta charset=utf-8><title>background-image</title><style>" _
& "body {background-image: linear-gradient(white, gray); /* Путь к фоновому изображению */" _
& "background-color: #efefef; /* Цвет фона */" _
& "}</style></head><body><p>Привет</p></body>"
    Set Inspector = Nothing
End Sub

sFileName$ = "G:\888.xlsm"
sNewFileName$ = "G:\111\999.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set objExcel = New Excel.Application
Set myEx = objExcel.Workbooks.Open(sFileName)
    myEx.SaveAs FileName:=sNewFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Set myEx = Nothing
Set objExcel = Nothing

Application.DisplayAlerts = True
Application.ScreenUpdating = True

sFileName$ = "G:\888.xlsm"
sNewFileName$ = "G:\111\999.xlsx"
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Workbooks.Open sFileName
ActiveWorkbook.SaveAs FileName:=sNewFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close


Application.DisplayAlerts = True
Application.ScreenUpdating = True

Private Function Инфо(ByVal Name As String, ByVal DialogName As String)
Application.ScreenUpdating = False
Sheets(DialogName).Visible = xlSheetVisible
Range(Name).Copy
Sheets(DialogName).Select
ActiveSheet.Shapes("Dialog 1").Select
ActiveSheet.Paste ' НА ЭТОЙ КОМАНДЕ ВЫЛЕТАЕТ ОШИБКА!!!!
Selection.ShapeRange.IncrementLeft 6#
Selection.ShapeRange.IncrementTop 20
Sheets("ОБРАЗЕЦ").Select
DialogSheets(DialogName).Show
Range(Name).Copy
Application.ScreenUpdating = True
End Function

Sub Formulas_To_Values_Book()
'преобразование формул в значения во всей книге
    For Each ws In ActiveWorkbook.Worksheets
        ws.UsedRange.Value = ws.UsedRange.Value
    Next ws
End Sub

Sub Перевозчик1()
Перевозчик = [MU_Перевозчик1] ' = Машина
ПеревозчикиИнфо Перевозчик
End Sub
Sub Перевозчик2()
Перевозчик = [MU_Перевозчик2] ' = Поезд
ПеревозчикиИнфо Перевозчик
End Sub
Private Function ПеревозчикиИнфо(ByVal Перевозчик As String)
Application.ScreenUpdating = False
'ааааа = "[" & Перевозчик & "]"
'[ааааа].Copy  НЕ РАБОТАЕТ!
    [Перевозчик].Copy 'НЕ РАБОТАЕТ, если "Перевозчик" заменить на "Машина" или "Поезд" всё ок, но мне необходимо чтоб само менялось, в зависимости с какого Sub зашёл
    Sheets("PEREV").Select
    ActiveSheet.Shapes("Check Box 3").Select
    ActiveSheet.Paste       'Вставляет скопированную таблицу в диалоговое окно
    Selection.ShapeRange.IncrementLeft 6#
    Selection.ShapeRange.IncrementTop 20
    Sheets("Ежедневник").Select
DialogSheets("PEREV").Show
End Function