Sub PtimerSchet()
    Dim mA()
    mA = Лист5.Range("A2:B51").Value
    For i = 1 To 52
        If mA(i, 1) = pNum Then
            pTime = TimeValue("0:00:0" & mA(i, 2))
            DoEvents
             Application.Wait Now + pTime ' ЗАМЕНИЛ НА WAIT И ДОСТИГ НУЖНОГО МНЕ РЕЗУЛЬТАТА
            Exit For
        End If
    Next i
End Sub

public pNum as Long 'Порядковый номер в таблице с нужным временем задержки
Sub listAnalisys()
    pNum = 1 'Порядковый номер в таблице с нужным временем задержки
    PtimerSchet ' Запуск таймера
    EffEng ' Выполнение нужной процедуры
    pNum = 2 'Порядковый номер в таблице с нужным временем задержки
    PtimerSchet ' Запуск таймера
    EffRus ' Выполнение нужной процедуры
    pNum = 3 'Порядковый номер в таблице с нужным временем задержки
    PtimerSchet ' Запуск таймера
    EffAll ' Выполнение нужной процедуры
    pNum = 4 'Порядковый номер в таблице с нужным временем задержки
    PtimerSchet ' Запуск таймера
    Total ' Выполнение нужной процедуры
End Sub

Public pTime As Date
Sub PtimerSchet() 'Таймер
    Dim mA()
    mA = Лист5.Range("A2:B51").Value 'таблица с указанием номера и времени задержки срабатывания процедуры
    For i = 1 To 52  
        If mA(i, 1) = pNum Then 'Перебираем массив чтобы найти нужное время задержки 
            pTime = TimeValue("0:00:0" & mA(i, 2)) 
            schetchik
            Exit For
        End If
    Next i
End Sub
'------------------------------------------------------------------------
Sub schetchik()
Application.ScreenUpdating = False
        pTime = pTime - TimeValue("0:00:01")
   If pTime > 0 Then 
        Application.OnTime Now + TimeValue("00:00:01"), "schetchik" ' Выполняем перезапуск процедуры с задержкой в 1 сек
    Else
        Application.ScreenUpdating = True
        Exit Sub 'В момент когда pTime будет равен 0, завершаем процедуру
    End If
End Sub

Sub SchetEsliMn()
'Формула в коде VBA=СЧЁТЕСЛИМН(AX$12:AX$10000;"*";$B$12:$B$10000;$B4)
    '--------------------------------
    Dim mA(), mA2(), mA3(), mA4()
    Dim i As Long, j As Long, y As Long
    Dim rCntD As New Collection
    '--------------------------------
    mA = [b4:b9].Value: ReDim mA4(1 To UBound(mA), UBound(mA, 2)) 'Perechen tovarov
    mA2 = [b12:b10000].Value   'Tovari po gorodam
    '-------------------------------------------------------------------
    For y = 50 To 171
        mA3 = Range(Cells(12, y), Cells(10000, y)).Value 'massiv rezultatov Kak sdelat ego plavayushim(dinamicheskim???)
    '---------------------------------
        For i = 1 To UBound(mA)      '[b4:b9].Value
            For j = 1 To UBound(mA2) '[b12:b10000].Value
                If mA2(j, 1) = mA(i, 1) Then rCntD.Add (mA3(j, 1)) '[ax12:ax10000].Value
             Next j
             '~~~~~~~~~~~~~~~~~~~~~~~~
             mA4(i, 0) = rCntD.Count: Set rCntD = New Collection
             '~~~~~~~~~~~~~~~~~~~~~~~~
        Next i
        '--------
        Cells(4, y).Resize(UBound(mA4), UBound(mA4, 2)).Value = mA4: y = y + 10
    Next y
    '-------------------------------------------------------------------
End Sub

Sub SchetEsliMn()
    '--------------------------------
    Dim mA(), mA2(), mA3(), mA4()
    Dim i As Long, j As Long
    '--------------------------------
    '=СЧЁТЕСЛИМН(AX$12:AX$10000;"*";$B$12:$B$10000;$B4) 'На примере формулы
    
     mA = [b4:b9].Value        'Перечень товаров
    mA2 = [b12:b10000].Value   'Товары по городам
    mA3 = [ax12:ax10000].Value 'Данные, которые необходимо обработать 
             '[ax4:ax9].Value      'Куда должны сесть результаты
   
    For i = 1 To UBound(mA)
        For j = 1 To UBound(mA2)
           '......................................Обработка данных и определение количества 
        Next j
    Next i
End Sub

Function MaxIf(TableParam As Range, SearchParam As String, Rezults As Range) As String
'*********************************************************************************
' ***********>< Nahojdenie max znacheniya po usloviyu ><**************
'*********************************************************************************
    Dim mA(), mA2(), i As Long
    mA = TableParam
    mA3 = Rezults
    ReDim mA2(1 To UBound(mA), 1)
    '-----------------------------------
    For i = 1 To UBound(mA)
        If mA(i, 1) = SearchParam Then
            mA2(i, 0) = mA3(i, 1)
        End If
    Next i
    '-----------------------------------
    MaxIf = Format(Application.Max(mA2), "hh:mm:ss") ' Pri zamene .Min na .Max menyaem kriteriy poiska
End Function
 

d.item(t) =Cells(i, 7) & " " & Cells(i, 8) & " " &................ & " " &  d.item(t) + .Cells(i, 4)

Set d = CreateObject("Scripting.Dictionary"): d.comparemode = 1
         Set m = CreateObject("Scripting.Dictionary"): m.comparemode = 1
 ......................
     d.item(t) = d.item(t) + .Cells(i, 4)
        m.item(t) = .Cells(i, 7) & " " & .Cells(i, 8)  & " " & . ..... n
...............
For Each k In d.keys
      kVal=split(m.item(k)," ")
msg "1= " & kVal(0) & "2= " & kVal(1).......
    Next

Set d = CreateObject("Scripting.Dictionary"): d.comparemode = 1
    Set f = CreateObject("Scripting.Dictionary"): f.comparemode = 1
     Set m = CreateObject("Scripting.Dictionary"): m.comparemode = 1
 ......................
     d.item(t) = d.item(t) + .Cells(i, 4)
        m.item(t) = .Cells(i, 7)
        f.item(t) = .Cells(i, 8)

 iLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 4 To iLastRow 
        If .Cells(i, 1) = Klient Then ' находим клиента по запросу 
        kPrih = .Cells(i, 2).Value 'вытаскиваем код прихода
        
        .............
        
        End If
    Next i

xp=activeworkbook.path 
'массив перебора имен
Set wb = ActiveWorkbook
wb.SaveAs Filename:=xp & "\" & "Отчеты" & "\" & " список листов " & ".xlsb"

 ReDim arr(1 To col.Count)
    For Each el In col
     i = i + 1
     arr(i) = el
    Next
    Sheets(arr).Copy 

CreateObject("Scripting.Dictionary"): .comparemode = 1