Vba helper

'Лочим колонку
Sub Lock_Column()
ActiveSheet.Unprotect
Cells.Locked = False
Columns("B:B").EntireColumn.Locked = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="poi"
End Sub
'Анлочим колонку
Sub UnLock_Column()
ActiveSheet.Unprotect Password:="poi" 'этого уже достаточно, чтобы снять блок
Cells.Locked = False
Columns("B:B").EntireColumn.Locked = False
End Sub

'Offset
Sub MoveDown()
ActiveCell.Offset(1, 0).Select 'ячейка внизу
End Sub
Sub MoveUp()
ActiveCell.Offset(-1, 0).Select 'ячейка сверху
End Sub
Sub MoveRight()
ActiveCell.Offset(0, 1).Select 'ячейка справа
End Sub
Sub MoveLeft()
ActiveCell.Offset(0, -1).Select 'ячейка слева
End Sub

Sub Ctrl_Plus()
Range(ActiveCell.Address).End(xlDown).Select 'ctrl+стрелка вниз
Range(ActiveCell.Address).End(xlToRight).Select 'ctrl+стрелка вправо
Range(ActiveCell.Address).End(xlUp).Select 'ctrl+стрелка вверх
Range(ActiveCell.Address).End(xlToLeft).Select 'ctrl+стрелка влево
End Sub

'Параметры "Сохранить как"
SaveAs(FileName,FileFormat,Password,WriteResPassword,ReadOnlyRecomended,CreateBackUp,AddtoMRU,TextCodePage,TextVisualLayout)
FileName - String - Имя файла
FileFormat - Integer - формат
Password - String - Пароль (будет использоваться для открытия)
WriteResPassword - String - Пароль (будет использоваться для записи изменений)
ReadOnlyRecomended - Boolean - При открытии "вылазит" сообщение о том, что файл может быть открыт только для чтения.
CreateBackUp - Boolean - создать резервный файл
AddtoMRU - Boolean - добавить имя файла в список недавно открытых в меню "Файл"
TextCodePage - не используется
TextVisualLayout - не используется 

''Параметры "Открыть"
Open(Filename,UpdateLinks,ReadOnly,Format,Password,WriteResPassword,IgnoreReadOnlyRecomended,Origin,Delimiter,Editable,Notify,Converter,AddToMRU);
Filename - String - Имя файла
UpdateLinks - Integer - Режим обновления ссылок в рабочей книге
ReadOnly - Boolean - открыть только для чтения
Format - Integer - формат открытия текстовых файлов
Password - String - Пароль
WriteResPassword - String - Пароль для сохранения изменений
IgnoreReadOnlyRecomended -Boolean- отключение сообщения только для чтения
Origin - Ineger - кодировка для открываемого текстового файла
Delimiter - Integer - код симбола-разделителя колонок для открываемого текстового файла
Editable - Boolean - доп. режим при открытии Excel-файлов более ранных версий, чем версия 5.0
Notify - Boolean - Если была попытка открыть файл в режиме чтение/запись, но в этот момент это было невозможно, то при значении True этого аргумента приложение получит уведомление когда файл станен доступен. Если False или значение опущено, и файл занят, то попытки открыть его для чтения/обречены на неудачу.
Converter - Integer - индекс конвертора, используемого при открытии файла
AddToMRU Boolean - добавить имя файла в список недавно открытых в меню "Файл" 

'Вкл./Выкл. автофильтр
Sub AutoFilterOn(i As Boolean, Optional j)
    If IsMissing(j) Then j = 1
    Rows(j).AutoFilter
    If ActiveSheet.AutoFilterMode <> i Then
        Rows(j).AutoFilter
    End If
End Sub

'Работа с формой:
UserForm1.Hide 'скрыть форму  
UserForm1.Repaint 'дожидаемся перерисовки формы
Мб Set UserForm1 = Nothing

 'разъединяем ячейки
rn.UnMerge

'Количество видимых ячеек в колонке
ErrorOrNot = Workbooks(city).Sheets("Список договоров").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count

template.Saved = True 'указываем, что книга сохранена, хотя это не так
Application.CutCopyMode = False 'снимаем выделение для копирования

If Dir(iFileName) <> "" Then ' Dir(Path) - проверяет наличие файла по указанной директории, допускаются символы * и ? (для одного знака)
   MsgBox "Указанный файл наличествует", , ""
Else
   MsgBox "Указанный файл отсутствует или является скрытым и т.п.", , ""
   'Если нужно проверить наличие файла имеющего аттрибуты :
   'скрытый,только для чтения,..., то
   'Dir(iFileName,vbHidden+vbReadOnly+...)
End If


    Vp.Range("A5:EX" & Hvp).Select ' сортировка данных
    Vp.Sort.SortFields.Clear
    Vp.Sort.SortFields.Add Key:=Vp.Range("X5:X" & Hvp), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    Vp.Sort.SortFields.Add Key:=Vp.Range("AT5:AT" & Hvp), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With Vp.Sort
        .SetRange Vp.Range("A5:EX" & Hvp)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Application.OnTime Now + TimeValue("00:00:2"), "MyMacro" ' ожидание до инициализации формы "MyMacro"
objOutlookApp.inspectors.Count 'смотрим количество текущих открытых писем в outlook
[a2].Activate: ActiveWindow.FreezePanes = True ' закрепляем первую строку листа
Range(<your Column>).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range(<the same your Column>), Unique:=True 'определение уникальных значений в диапазоне
Application.Goto "Open_Code_Editor.open_code_editor" 'открыть редактор кода в месте "Имя Модуля.Имя Макроса"

'Выводит все фигуры со всех листов в окно Immediate
Sub ВыводСпискаАвтофигурСКоординатами()
    Dim sh As Worksheet, sha As Shape
    For Each sh In ThisWorkbook.Worksheets
        Debug.Print "=== Лист «" & sh.Name & "» - количество фигур: " & sh.Shapes.Count & " ==="
        For Each sha In sh.Shapes
            n = n + 1: Debug.Print "   Фигура №" & n & " с названием «" & sha.Name & "»"
            Debug.Print "      Координаты верхнего левого угла: X=" & sha.Left & "; Y=" & sha.Top
            Debug.Print "      Координаты правого нижнего угла: X=" & sha.Left + sha.Width & "; Y=" & sha.Top + sha.Height
            Debug.Print "      Размеры фигуры: ширина=" & sha.Width & "; высота=" & sha.Height
            Debug.Print "      Тип фигуры: " & sha.Type & "; тип автофигуры: " & sha.AutoShapeType
        Next sha
        Debug.Print "=== Конец просмотра листа «" & sh.Name & "» ===" & vbNewLine
    Next sh
End Sub

Выбираем файл:
Dim FilesFolder As FileDialog
Set FilesFolder = Application.FileDialog(msoFileDialogFilePicker)
    With ReportFile
      '  .Filters.Add "Excel files", "*.xls*;*.xla*;*.xlsx*", 1
        .Title = "Создайте новый файл 'Отчет по заявкам...' с отчетной датой и выберите его"
        .AllowMultiSelect = False
        .InitialFileName = "C:\"
        .Show
    End With

Вот это изменит "Бойков Андрей Викторович" на "Андрей Бойков":
=ПСТР(M1;НАЙТИ(" ";M1)+1;ПОИСК("@";ПОДСТАВИТЬ(M1;" ";"@";ДЛСТР(M1)-ДЛСТР((ПОДСТАВИТЬ(M1;" ";"")))))-НАЙТИ(" ";M1)-1)&" "&ЛЕВСИМВ(M1;(НАЙТИ(" ";M1)-1))

Вывод подряд значений удовлетворяющим условию (поиск снизу вверх):
=ЕСЛИОШИБКА(ПРОСМОТР(;-1/(I:I=1)/ЕНД(ПОИСКПОЗ(G:G;K$1:K1;));G:G);"")

Номер недели в году: =НОМНЕДЕЛИ(L6;15)
Номер недели как принято в России: =НОМНЕДЕЛИ(L7;2)

Против зависания макроса
Public sub Pause()
start=timer
do while timer < start+0.0001
do events ' передача управления другим задачам и процессам на компе
waitmessage 'API, надо объявить.
Private Declare Function WaitMessage Lib <<user32.dll>> as Long
End Sub

Function GetColNameByNumber(byval col As Long)
'получаем имя колонки по её номеру
 GetColNameByNumber = Split(Cells(1, col).Address, "$")(1)
End Function

Public Function IsFormLoaded(ByVal sFormName As String) As Boolean
'показывает загружена ли форма
    Dim i_l As Integer
    If Forms.Count < 1 Then IsFormLoaded = False: Exit Function
    For i_l = cNull To Forms.Count - vbNull
        If sFormName = Forms(i_l).Name Then IsFormLoaded = True: Exit Function
    Next
End Function

'включаем выключаем ускорение макросов
Public Function AccelerationMacro(On_v_Off As Boolean, Optional ScreenUdating As Boolean = False, _
   Optional Calculation As Integer = xlCalculationManual, Optional EnableEvents As Boolean = False, _
   Optional DisplayAlerts As Boolean = False, Optional DisplayStatusBar As Boolean = False)
   If On_v_Off = True Then
          'Больше не обновляем страницы после каждого действия
      If ScreenUdating = False Then Application.ScreenUpdating = False
            'Отключаем события
      If EnableEvents = False Then Application.EnableEvents = False
            'Расчёты переводим в ручной режим
      If Calculation = xlCalculationManual Then Application.Calculation = xlCalculationManual
            'Отключаем сообщения Excel
      If DisplayAlerts = False Then Application.DisplayAlerts = False
            'Отключаем статусную строку
      If DisplayStatusBar = False Then Application.DisplayStatusBar = False
    Else
      Application.ScreenUpdating = True
      Application.EnableEvents = True
      Application.Calculation = xlCalculationAutomatic
      Application.DisplayAlerts = True
      Application.DisplayStatusBar = True
    End If
End Function

'смена стиля ссылок на ячейки
Sub R1C1_A1()
    If Application.ReferenceStyle = xlA1 Then
    Application.ReferenceStyle = xlR1C1
    Else
     Application.ReferenceStyle = xlA1
    End If
End Sub



Sub Макрос5()
'
' Макрос5 Макрос
Dim o_pivotitem As Object, o_pivotitem2 As Object, sht As Worksheet, o_pivot_name As PivotTable
Dim arr_towns(1 To 34) As String
'ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields("Регион").EnableItemSelection = True
'ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields("Наши города").EnableItemSelection = True
Worksheets("кол-во а_м").Select
n_town = ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields(Cells(4, 1).Value).PivotItems.Count
For Each o_pivotitem In Worksheets("кол-во а_м").PivotTables("СводнаяТаблица1").PivotFields(Cells(4, 1).Value).PivotItems
    k = k + 1
    arr_towns(k) = o_pivotitem.Name
Next


        our_field = Cells(4, 1).Value '"Наши города"
        For Each o_pivotitem In ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields(our_field).PivotItems
            For Each sht In ThisWorkbook.Worksheets
            If sht.Name <> "ср.по марке" Then
            sht.Select
                If o_pivotitem <> "" Then
                With ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields(our_field)
                    cur_town = o_pivotitem.Name
                    .PivotItems(o_pivotitem.Name).Visible = True
                    For Each o_pivotitem2 In .PivotItems
                        If o_pivotitem2.Name <> o_pivotitem.Name Then
                        .PivotItems(o_pivotitem2.Name).Visible = False
                        End If
                    Next
                    .EnableItemSelection = False
                End With
                ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("Регион").EnableItemSelection = False
                End If
            End If
            Next
           

        Next
End Sub

'При shift+delete будет запускаться макрос MacroName
Application.OnKey "+{DELETE}", "MacroName"


Sub saveAttachments()
'сохраняем все вложения в выделенной папке Outlook
    Dim objOutlookApp As Object
    Dim sExt$, sFolderPath$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
            On Error Resume Next
               'пробуем подключиться к Outlook, если он уже открыт
            Set objOutlookApp = GetObject(, "Outlook.Application")
            Err.Clear 'Outlook закрыт, очищаем ошибку
            If objOutlookApp Is Nothing Then
                Set objOutlookApp = CreateObject("Outlook.Application")
            End If
            'произошла ошибка создания объекта - выход
            If Err.Number <> 0 Then Set objOutlookApp = Nothing:  Exit Sub
            objOutlookApp.session.Logon
           
sFolderPath = ActiveSheet.Range("b5").Value
If Dir(sFolderPath, vbDirectory) = "" Then MsgBox "Не существует указанной папки. Создайте её сначала": Exit Sub

ActiveSheet.Range("A7:A" & ActiveSheet.Columns(1).SpecialCells(xlLastCell).Row).ClearContents
   
    For Each oItem In objOutlookApp.Explorers.Item(1).currentfolder.items
        For Each att In oItem.attachments
        sExt = ФАЙЛРАСШИР(att)
        If sExt <> "png" And sExt <> "jpg" Then
            att.SaveAsFile sFolderPath & "\" & att.Filename
            ActiveSheet.Cells(Application.Match("*", ActiveSheet.Columns(1), -1) + 1, 1).Value = att.Filename
        End If
        Next
    Next
   
Set objOutlookApp = Nothing
Set oItem = Nothing: Set oItem = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Private Sub ListBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'при нажатии на Enter запускаем макрос
    If KeyAscii = 13 Then
        ListBox1_LostFocus
    End If
End Sub


Function countUniqueValues(rng As range, Optional rng2 As range) As Long
'количество уникальных значений
Application.ScreenUpdating = True
    Dim l_arr As Long, n As Long, i As Long
      Dim avArr() As String
      a = rng.Row + rng.Count - 1
      a = rng.Worksheet.Cells(a, rng.Column).End(xlUp).Row - rng.Row + 1
      Set rng = rng.Resize(a)
      arr_of_range = rng
      l_arr = UBound(arr_of_range)
      With New Collection
          On Error Resume Next
          For n = 1 To l_arr
          .Add arr_of_range(n, 1), CStr(arr_of_range(n, 1)) 'Cstr() - если числа попадаются
            If Err = 0 And arr_of_range(n, 1) <> "" Then
                  i = i + 1
              Else: Err.Clear
              End If
          Next
      a = rng2.Row + rng2.Count - 1
      a = rng2.Worksheet.Cells(a, rng2.Column).End(xlUp).Row - rng2.Row + 1
      Set rng2 = rng2.Resize(a)
      arr_of_range = rng2
      l_arr = UBound(arr_of_range)
          For n = 1 To l_arr
          .Add arr_of_range(n, 1), CStr(arr_of_range(n, 1)) 'Cstr() - если числа попадаются
            If Err = 0 And arr_of_range(n, 1) <> "" Then
                  i = i + 1
              Else: Err.Clear
              End If
          Next
         
      End With
countUniqueValues = i
End Function


Sub DescribeFunction()
'При выполнении добавляется описание к пользовательской функции
    Dim FuncName As String
    Dim FuncDesc As String
    Dim FuncCat As Long
    Dim Arg1Desc As String, Arg2Desc As String
    FuncName = "Draw"
    FuncDesc = "Содержимое случайной ячейки диапазона"
    FuncCat = 5 'Ссылки и массивы
    Arg1Desc = "Диапазон, который содержит значения"
    Arg2Desc = "(не обязательный) Если False или отсутствует, _
            функция Rnd не пересчитывается. "
        Arg2Desc = Arg2Desc & "Если True, функция Rnd пересчитывается "
        Arg2Desc = Arg2Desc & "при любом изменении на листе."
        Application.MacroOptions _
            Macro:=FuncName, _
            Description:=FuncDesc, _
            Category:=FuncCat, _
            ArgumentDescriptions:=Array(Arg1Desc, Arg2Desc)
End Sub

'Создание папки\создать папку
With CreateObject("Scripting.FileSystemObject")
    .CreateFolder (ThisWorkbook.Path & "\" & ActiveSheet.Range("Q6").Value)
    .CreateFolder (ThisWorkbook.Path & "\" & ActiveSheet.Range("Q7").Value)
End With

'нашли столбец с датой в 1-й строке и раскрыли его
col = Application.Match(CDbl(d_date), Workbooks(name_of_order).Sheets("Лист2").Rows(1), 0)
Workbooks(name_of_order).Sheets("Лист2").Columns(col).Hidden = False

'обновляем QueryTable
ThisWorkbook.Sheets(sh_info).Range("A2").QueryTable.Refresh BackgroundQuery:=False

'обновляем таблицу с подключением
ThisWorkbook.Sheets(sh_dealer_payments).Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False

'обновляем сводную
ThisWorkbook.Sheets(sh_for_copy).PivotTables("СводнаяТаблица1").PivotCache.Refresh

ThisWorkbook.Sheets(sh_info).AutoFilterMode = False 'удаляем фильтр полностью
ErrorOrNot = ThisWorkbook.Sheets(sh_info).AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count 'количество видимых ячеек (включая заголовок)

ActiveSheet.ShowAllData 'сбрасывает все фильтры

    'удаляем н/д шки
    .Range("2:" & pivot_last_row).AutoFilter Field:=3, Criteria1:="#Н/Д"
    ErrorOrNot = .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count
    If ErrorOrNot > 1 Then
    .Rows("3:" & pivot_last_row).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    End If

Работа с файлами - это надо отдельную статью писать. FileCopy и т.д.

ThisWorkbook.SaveCopyAs Replace(ThisWorkbook.FullName, "Сводный", "Сводный - копия") ' делаем копию текущей книги (обычно вначале делаю, чтобы не загадить ничего)

    ActiveSheet.Range("2:6762").AutoFilter Field:=25, Criteria1:= _
        "<>#Н/Д", Operator:=xlAnd '  - почему-то такая фильтрация не работает!

If Dir(s_curfilepath) <> "" Then MsgBox "Файл уже существует": Exit Sub ' проверка существования файла

'так тоже можно обновлять QueryTables
Set qtku = ThisWorkbook.Sheets("KU").QueryTables("Query from Microsoft CRM KU")
qtku.CommandText = ThisWorkbook.Sheets("main").Range("W2") 'вставляем sql-запрос
qtku.BackgroundQuery = False
qtku.Refresh

или
ThisWorkbook.Sheets(sh_info).Range("A2").QueryTable.Refresh BackgroundQuery:=False

'обновляем сводную
ThisWorkbook.Sheets(sh_for_copy).PivotTables("СводнаяТаблица1").PivotCache.Refresh

    'удаляем н/д шки
    pivot_last_row = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("2:" & pivot_last_row).AutoFilter Field:=3, Criteria1:="#Н/Д"
    ErrorOrNot = .AutoFilter.Range.Columns(2).SpecialCells(xlCellTypeVisible).Cells.Count
    If ErrorOrNot > 1 Then
    .Rows("3:" & pivot_last_row).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
    End If
    .ShowAllData

cn - соединение ADODB.Connection
cn.CommandTimeout = 3600 'увеличиваем время запроса, чтобы не вылетала ошибка "вермя ожидания запроса истекло"

=ЛЕВСИМВ(H2;НАЙТИ("\";H2)-2)    'из предложения в номер предложения
=СУММПРОИЗВ(1,02^СТРОКА(ДВССЫЛ("1:"&C3))) - сумма степенного ряда, где C3 - это степень
=ТЕКСТ(G1992;"М/ГГГГ") - из даты в номер ДЛ
=ПСТР(ЯЧЕЙКА("имяфайла";A1);ПОИСК("]";ЯЧЕЙКА("имяфайла";A1))+1;255) - имя листа
=ИНДЕКС(B:B;МАКС((A9:A108="искомое")*СТРОКА(A9:A108))) - впр снизу вверх 
=ИНДЕКС(2:11;АГРЕГАТ(15;6;(СТРОКА(2:11)-1)/($I2=2:11);1))


VBA:
Now() - дата с временем
Date - дата без времени


If Workbooks.Count > 1 Then
    ThisWorkbook.Save
    ThisWorkbook.Close
Else
    ThisWorkbook.Save
    Application.ScreenUpdating = True
    Application.Quit ' ActiveWorkbook.Close True
End If

Sub Открыть_папку_IEloads()
CreateObject("Shell.Application").Explore "C:\Users\fpotokin\Downloads\IE_loads"
End Sub
Sub Открыть_папку_воронки()
CreateObject("Shell.Application").Explore ThisWorkbook.Sheets("Рассылка воронки").Range("B3").Text
End Sub

Sub DelTestFiles()
'удаляем созданные для теста файлы и папки
'они указанные после текста "Удалять после теста" в L33
Set fso = CreateObject("Scripting.FileSystemObject")
Set cell = ThisWorkbook.Sheets("Main").Range("M34")

If fso.FileExists(cell) Then Kill cell
End Sub

Sub Открыть_Разработчик_на_макросе_отчета()
Application.Goto "Orders_Report_Module1.Макрос_Отчета_по_заявкам"
End Sub

Sub отправить()
Dim T As Single
T = Timer
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim lr As Long, lLastR As Long
    Dim d_voronka_delivery  As Date
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    
       'пробуем подключиться к Outlook, если он уже открыт
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear 'Outlook закрыт, очищаем ошибку
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'произошла ошибка создания объекта - выход
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
    objOutlookApp.session.Logon

    Set sh1 = ThisWorkbook.Sheets("Рассылка воронки") 'ActiveSheet ' это у нас лист Список, где мэчатся подразделения, регионы и КОМУ, собственно отправка
    sh1.Calculate
    h = sh1.Cells(Rows.Count, 1).End(xlUp).Row ' последнюю строку ищем
    If h < 6 Then MsgBox ("что-то не так с количеством строк")
    d_voronka_delivery = CDate(sh1.Range("B4"))
    
    'ищем файлы
    Dim FolderPath As String
    FolderPath = sh1.Range("b3") 'путь и папка с файлами
    Dim FileSystemObject As Object
    Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
    Dim f As Object
    Set f = FileSystemObject.GetFolder(FolderPath)
        'проверяем наличие папки
        If FileSystemObject.FolderExists(FolderPath) = False Then Set objOutlookApp = Nothing: MsgBox "Отсутствует указанная папка " & sh1.Range("b3"): Exit Sub
        
    currcount = 1
    ReDim arr(1 To 2, 1 To currcount) As String
    i = 1
    currcount = 0
For Each ofolder In f.SubFolders
'ищем в подпапках
    count1 = ofolder.Files.Count
    currcount = currcount + count1
    ReDim Preserve arr(1 To 2, 1 To currcount) As String
    For Each ofile In ofolder.Files
     arr(1, i) = ofolder.path
     arr(2, i) = ofile.Name
    i = i + 1
    Next ofile
Next ofolder
count0 = f.Files.Count
currcount = currcount + count0
ReDim Preserve arr(1 To 2, 1 To currcount) As String
For Each ofile In f.Files
'файлы в папке пихаем в массив
     arr(1, i) = FolderPath
     arr(2, i) = ofile.Name
    i = i + 1
Next ofile
    'установка объекта в значение Nothing требуется для освобождения памяти, которая была выделена для создания этого объекта
    Set FileSystemObject = Nothing
    Set f = Nothing
    'закончили искать файлы, теперь они в массиве arr
    Set fso = CreateObject("Scripting.FileSystemObject") ' создаем системный объект
    'тут надо проверить все ли указанные файлы присутствуют в массиве
    For i = 6 To h
    If sh1.Cells(i, 4) = 1 Then
        For k = 1 To currcount
            If Left(LCase(arr(2, k)), InStrRev(arr(2, k), ".") - 1) <> LCase(sh1.Cells(i, 1)) And k = currcount Then
            otvet = MsgBox("Файлов по указанному пути не найдено: " & sh1.Cells(i, 1) & ". Выйти из макроса (Да) или продолжить выполнение (Нет)?", vbYesNo)
            If otvet = 6 Then Exit Sub
            End If
            If Left(LCase(arr(2, k)), InStrRev(arr(2, k), ".") - 1) = LCase(sh1.Cells(i, 1)) Then Exit For
        Next k
    End If
    Next i
    
    For i = 6 To h
        If sh1.Cells(i, 4) = 1 Then
            ' проверка существования файла
            For k = 1 To currcount
            If Left(LCase(arr(2, k)), InStrRev(arr(2, k), ".") - 1) = LCase(sh1.Cells(i, 1)) Then Exit For
            If Left(LCase(arr(2, k)), InStrRev(arr(2, k), ".") - 1) <> LCase(sh1.Cells(i, 1)) And k = currcount Then MsgBox "Файла по указанному пути не найдено" & sh1.Cells(i, 1): flag = 1
            Next

           'Назначаем конфигурацию CDO
         Set objMail = objOutlookApp.CreateItem(0)   'создаем новое сообщение
              'создаем сообщение
                With objMail
                    .To = sh1.Cells(i, 5).Value 'адрес получателя
                    .CC = sh1.Cells(i, 7).Value 'адрес для копии
                    .Subject = sh1.Cells(1, 8) 'тема сообщения
                    .HTMLBody = sh1.Cells(1, 11)  'текст сообщения
                    .Attachments.Add arr(1, k) & "\" & arr(2, k)
                    .deferredDeliveryTime = d_voronka_delivery
                End With
                If sh1.Cells(1, 6) = ".display" Then objMail.display
                If sh1.Cells(1, 6) = ".send" Then objMail.send
        End If
    Next i
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
If sh1.Range("L22").Value = True And sh1.Range("L20").Value = False Then
MsgBox "Execution Time:  " & Format(Fix(Timer - T) / 86400, "h:mm:ss") & Format(Timer - T - Fix(Timer - T), ".00000")
End If

If sh1.Range("L20").Value = True Then
    If IsBookOpen("Макрос для регионов.xlsm") Then Workbooks("Макрос для регионов.xlsm").Close True
    Application.DisplayAlerts = True
        Call open_regions
    
End If
Set sh1 = Nothing
End Sub

Public Sub open_regions()
If ThisWorkbook.Sheets("Рассылка воронки").Range("l20") Then Workbooks.Open ThisWorkbook.Sheets("Main").Range("D24").Value & "\Макрос для регионов.xlsm", 3


    If autorunconditions Then
    ThisWorkbook.Save
    If IsBookOpen("Макрос для регионов.xlsm") Then Workbooks("Макрос для регионов.xlsm").Close True
    End If
    
DoEvents
If Workbooks.Count > 1 Then
    ThisWorkbook.Save
    ThisWorkbook.Close
Else
    ThisWorkbook.Save
    Application.ScreenUpdating = True
    Application.Quit ' ActiveWorkbook.Close True
End If
End Sub


Sub DelOutlookMsg()
'удаляем созданные сообщения в outlook с указанной темой в ячейке H3
    Dim objOutlookApp, curMsg As Object
    Dim MsgCount As Byte
Application.ScreenUpdating = False
    MsgCount = 0
            On Error Resume Next
               'пробуем подключиться к Outlook, если он уже открыт
            Set objOutlookApp = GetObject(, "Outlook.Application")
            Err.Clear 'Outlook закрыт, очищаем ошибку
            If objOutlookApp Is Nothing Then
                Set objOutlookApp = CreateObject("Outlook.Application")
            End If
            'произошла ошибка создания объекта - выход
            If Err.Number <> 0 Then Set objOutlookApp = Nothing:  Exit Sub
            objOutlookApp.session.Logon
            
    'считаем количество черновиков
    MsgCount = objOutlookApp.inspectors.Count
    If MsgCount < 1 Then MsgBox ("Нет открытых сообщений"): Exit Sub
        For i = MsgCount To 1 Step -1
        'c = objOutlookApp.inspectors.Item(i).CurrentItem.Subject
        'сверяем тему письма с указанной
            If ThisWorkbook.Sheets("Рассылка воронки").Cells(3, 8) = objOutlookApp.inspectors.Item(i).CurrentItem.Subject Then

                Set curMsg = objOutlookApp.inspectors.Item(i)
                curMsg.Close 1
            End If
        Next i
Set objOutlookApp = Nothing
Set curMsg = Nothing
Application.ScreenUpdating = True
End Sub