Function SendEmailUsingOutlook(ByVal Email$, ByVal MailText$, Optional ByVal Subject$, Optional ByVal rootFile$, _
    Optional ByVal AttachFilename$, Optional ByVal FileName$, Optional ByVal sCbt$, Optional ByVal sCC$) As Boolean
    ' функция производит отправку письма с заданной темой и текстом на адрес Email
    ' с почтового ящика, настроенного в Outlook для отправки писем "по-умолчанию"
    ' Если задан параметр AttachFilename, к отправляемому письму прикрепляется файл (файлы)
    Dim i As Long, arr, aX1, aX2
    Dim strHTML As String
    
    On Error Resume Next: Err.Clear
    Dim OA As Object
    Dim OMail As Object
    
    Set OA = CreateObject("Outlook.Application")
    If OA Is Nothing Then MsgBox "Не удалось запустить OUTLOOK для отправки почты", vbCritical: Exit Function
    Set OMail = OA.CreateItem(0) 'создаем новое сообщение
 
    With OMail
        .To = Email$: .Subject = Subject$: .Body = MailText$
        If sCC$ <> "" Then .CC = sCC$
        
        .Importance = 2 ' 2 - важное, 1 - обычное, 0 - низкое
        .Attachments.Add rootFile
        ' Добавляем кнопки .VotingOptions в тему и гиперссылку на файл в текст письма
        .VotingOptions = sCbt$

        strHTML = "ДЛЯ СОГЛАСОВАНИЯ ИЛИ ОТКЛОНЕНИЯ ДОКУМЕНТА" & "<br>" & "ВОСПОЛЬЗУЙТЕСЬ КНОПКАМИ В ЗАГОЛОВКЕ СООБЩЕНИЯ"
        .HTMLBody = "<p>" & .Body & "</p>" & _
            "<a href=""" & rootFile & """ >" & FileName & "</a>" & _
            "<br><br>" & strHTML

        For i = 1 To 100000: DoEvents: Next    ' без паузы не отправляются письма без вложений
        Err.Clear: .Send
        SendEmailUsingOutlook = Err = 0
    End With
    Set OA = Nothing
    
End Function

Option Explicit
 
Sub test1()
    Dim r As Range, rCell As Range, s As String
    Dim arr1, arr2, arrShData, j As Long
    Dim colShapes As New Collection, Item As Variant, aMistake As String
     
    Dim arrKeysCol
     
    Set r = ThisWorkbook.Worksheets("TEST").Range("A2:A13")
    For Each rCell In r
        s = IIf(s = "", rCell.Value & "|" & rCell.Offset(0, 1).Value & "|" & rCell.Offset(0, 2).Value & "|" & rCell.Offset(0, 3).Value, _
            s & "#" & rCell.Value & "|" & rCell.Offset(0, 1).Value & "|" & rCell.Offset(0, 2).Value & "|" & rCell.Offset(0, 3).Value)
    Next
     
    Key = "TEST"
    arr1 = Split(s, "#")
    For j = 0 To UBound(arr1)
        arr2 = Split(CStr(arr1(j)), "|")
        On Error Resume Next
        colShapes.Add arr2, CStr(arr2(0))
        
        If Err.Number > 0 Then _
            aMistake = IIf(aMistake = "", CStr(arr2(0)), aMistake & "|" & CStr(arr2(0))): Err.Clear
            
        Erase arr2
    Next j
     
    ReDim arrKeysCol(colShapes.Count - 1)
    j = 0
    For Each Item In colShapes
        arrKeysCol(j) = Item(0)
        j = j + 1
    Next
     
End Sub

Private Sub UserForm_Activate()
    Me.lstbox_Tab.Clear
    With Me.lstbox_Tab
        .AddItem ""
        .List(0, 0) = "04"
        .List(0, 1) = ":"
        .List(0, 2) = "МВ"
        .List(0, 3) = "21.12.2021"
        .List(0, 4) = "21.12.2021"
        .List(0, 5) = "22"
        .List(0, 6) = ":"
        .List(0, 7) = "МВ"
        .List(0, 8) = "21.12.2021"
        .List(0, 9) = "21.12.2021"
        .List(0, 10) = "22"
        .List(0, 11) = ":"
        .List(0, 12) = "МВ"
        .List(0, 13) = "21.12.2021"
        .List(0, 14) = "21.12.2021"
        .List(0, 15) = "22"
        .List(0, 16) = ":"
        .List(0, 17) = "МВ"
        .List(0, 18) = "21.12.2021"
        .List(0, 19) = "21.12.2021"
        .List(0, 20) = "22"
    End With
End Sub

    Dim i As Long, j As Long
    i = 8
    For j = 8 To 10
        If Len(Sheets(1).Cells(i, 5)) <> 8 Then
            Sheets(1).Cells(i, 17) = CStr("0" & Sheets(1).Cells(i, 5))
            Sheets(1).Cells(i, 5) = Sheets(1).Cells(i, 17)
        Else
            Sheets(1).Cells(i, 17) = CStr(Sheets(1).Cells(i, 5))
        End If
        i = i + 1
    Next j

    Dim i As Long, j As Long
    i = 8
    For j = 8 To 10
        If Len(Sheets(1).Cells(i, 5)) <> 8 Then
            Sheets(1).Cells(i, 17) = CStr("0" & Sheets(1).Cells(i, 5))
        Else
            Sheets(1).Cells(i, 17) = CStr(Sheets(1).Cells(i, 5))
        End If
        i = i + 1
    Next j

Function mnmx(i As Double, v As Double, t As Double, s As Double, d As Double, f As Double, mn As Double, mx As Double)
' фукнкция поиска минимальных и максимальных значений из массива, _
состоящего из 6-ти элементов

Dim a(), b()
Dim u As Integer, raz As Integer

a = Array(i, v, t, s, d, f)
ReDim b(UBound(a))
For u = 0 To UBound(a)
    If (a(u) <> 0) Then
        b(raz) = a(u)
        raz = raz + 1
    End If
Next
ReDim Preserve b(raz)
mx = Application.Max(b)
mn = Application.Min(b)
End Function