Files_0ut = Application.GetOpenFilename(MultiSelect:=True)

Files_0ut = Application.GetOpenFilename("Files(*.*),*.*", 1, "Выбрать фото или Word файлы", , True)
If VarType(Files_0ut) = vbBoolean Then
Exit Sub
End If

avFiles = Application.GetOpenFilename _
                ("files(*.*),*.*", 1, "Выбрать  файлы", , True)
    If VarType(avFiles) = vbBoolean Then
        'была нажата кнопка отмены - выход из процедуры
        Exit Sub
    End If

Sub Отправка_по_Outlook()

strFileName = _
    Dir("\\Персональная\-  РАБОЧИЕ  -\Smart Skid\Скв. 722\2017\Скв. 722*.xls*") 'Проверка наличия файла

Set objOutlookApp = CreateObject("Outlook.Application")
    objOutlookApp.Session.Logon
    Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
    'если не получилось создать приложение или экземпляр сообщения - выходим
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    
    sTo = "3.14ston@mail.ru"   
    sSubject = "Smart Skid.Скв. 722"    

    'создаем сообщение
    With objMail
        .To = sTo 'адрес получателя
        .Subject = sSubject 'тема сообщения
        .Attachments.Add (strFileName)
        .Display 
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub

Sub Удал_Лишнее()
Dim lngN As Long
For lngN = 2 To Cells(Rows.Count, 1).End(xlUp).Row
   Cells(lngN, 1).Value = Right(CStr(Cells(lngN, 1).Value), InStr(CStr(Cells(lngN, 1).Value), "\"))
Next lngN
End Sub

Sub Макрос5()
    Cells.Find(What:="10:00", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=True).Activate
End Sub

Sub Макрос4()
    Dim iSource As ListObject
    Set iSource = ActiveCell.ListObject
    If iSource Is Nothing Then Exit Sub

    ActiveWorkbook.ActiveSheet.ListObjects(iSource).Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.ListObjects(iSource).Sort.SortFields.Add _
        Key:=Range("A:A"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.ListObjects(iSource).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Private Sub TextBox8_Change()

Dim LastRow As Long, i As Long, x As Long, Arr(), RW As Long
    ListBox1.Clear 'Очистили ЛистБокс
    For y = 3 To 28
        With Sheets(y) 'Применительно к указаным листам
            LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 'Нашли номер последней строки по столбцу A
            Arr = .Range(.Cells(1, 1), .Cells(LastRow, 7)).Value 'Забрали диапазон в массив
        End With
            With ListBox1 'Применительно к ЛистБоксу
                For i = 1 To UBound(Arr) 'Цикл по массиву
                    If UCase(Arr(i, 1)) Like UCase(Me.TextBox8) & "*" Then 'Если символы из ТекстБокса содержатся в начале строки в первом столбце массива, то
                        .AddItem "" 'Добавили пустую строку в ЛистБокс
                        .List(x, 0) = Arr(i, 1) 'Заполняем первый столбец ЛистБокса
                        .List(x, 1) = Arr(i, 2)
                        .List(x, 2) = Arr(i, 3)
                        .List(x, 3) = Arr(i, 4)
                        .List(x, 4) = Arr(i, 5)
                        .List(x, 5) = Arr(i, 6)
                        .List(x, 6) = Arr(i, 7)
                        x = x + 1 'Увеличиваем на единичку значение переменной (номер строки в ЛистБоксе)
                    End If
                Next
        End With
   Next
End Sub

Sub Макрос5()
  Dim Data As String
  Dim  x As Object
    

    
   Data = Format(Date, "mmmm")
    


    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(Data&"*17 УВШ №1")
    If Err = 0 Then
        Sheets(Data&"*17 УВШ №1").Select
    End If
    
End Sub

Private Sub ListBox1_Click()
    If ListBox1.ListIndex > -1 Then
       Application.Goto Application.Range(ListBox1.List(ListBox1.ListIndex, 1))
    End If
End Sub

Private Sub TextBox1_Change()
    ListBox1.Clear
    Dim iText$, iAddress$, iCount&, iList As Worksheet, iCell As Range
    iText = TextBox1.Value
   
    If iText <> "" Then 'If Len(iText) > 0
       For Each iList In ThisWorkbook.Sheets(Array("Август", "Сентябрь"))
           Set iCell = iList.Columns(6).Find(iText, , xlValues, xlPart)
           If Not iCell Is Nothing Then
              iAddress = iCell.Address
              Do
                ListBox1.AddItem
                ListBox1.List(iCount, 0) = iCell.Value
                ListBox1.List(iCount, 1) = iCell.Address(, , , True)
                iCount = iCount + 1
              Set iCell = iList.Columns(6).FindNext(iCell)
              Loop While iCell.Address <> iAddress
           End If
       Next
    End If    
End Sub

        lr = Cells(Rows.Count, 3).End(xlUp).Row
        For i = 2 To lr
            If Cells(i, 3) <> Cells(i - 1, 3) Then
            Cells(i - 1, 1).Resize(, 9).Borders(9).Weight = xlThin
            Cells(i - 1, 1).Resize(, 9).Borders(9).Color = -16776961
            End If
        Next i

Private Sub TextBox1_Change()
    ListBox1.Clear
    
    Dim iText$, iAddress$, iCount&, iList As Worksheet, iCell As Range
    iText = TextBox1.Value
    
    If iText <> "" Then 'If Len(iText) > 0
       For Each iList In ThisWorkbook.Worksheets
           Set iCell = iList.UsedRange.Find(iText, , xlValues, xlPart)
           If Not iCell Is Nothing Then
              iAddress = iCell.Address
              Do
                ListBox1.AddItem
                ListBox1.List(iCount, 0) = iCell.Value
'                ListBox1.List(iCount, 2) = iCell.Address(, , , True)
                ListBox1.List(iCount, 1) = iCell.Offset(, 1).Value
                iCount = iCount + 1
              Loop While iCell.Address <> iAddress
           End If
       Next
    End If
End Sub

Sub qwe()
Dim x As Range
    
    For Each x In Worksheets("Лист1").Range("B1:B100")
        If x = 1 Then x.Interior.Color = vbYellow
    Next x
    
End Sub

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim i As Long, lRow As Long, j As Integer, MyVar1 As Date, m As Date, Mes As Double
m = Date
Mes = TextBox1
 For j = 7 To 85 Step 4
 lRow = Cells(Rows.Count, j).End(xlUp).Row
    For i = 3 To lRow
        MyVar1 = Cells(i, j)
        If MyVar1 - m < Mes Then
        Cells(i, j).Interior.Color = 255
        Cells(i, j).Offset(, 2) = "1"
            If Cells(i, j) = "" Then
            Cells(i, j).Interior.Pattern = xlNone
            Cells(i, j).Offset(, 2) = ""
            End If
        End If
    Next i
  Next j
  Application.ScreenUpdating = True
End Sub