Private Sub StartTimer()
    Dim i As Long
    Dim curTime As Date
    Dim targetTime As Date
    Dim pauseTime As Date
    Dim curCell As Range
    Dim timeDiff As Long
    Dim msg As String
     
    For i = 2 To 22 ' диапазон ячеек от C2 до C22
        Set curCell = Application.ActiveSheet.Cells(i, 3)  'столбец C
        curTime = curCell.Value
        targetTime = curTime - TimeSerial(0, 5, 0) ' остановить таймер за 5 минут до времени
         
        Do While Now < targetTime ' ждем, пока не наступит нужное время
            pauseTime = Now + TimeSerial(0, 0, 1) ' ежесекундная пауза
            Application.Wait pauseTime
             
            curTime = curCell.Value ' обновляем текущее время в ячейке
            timeDiff = DateDiff("s", targetTime, curTime) ' вычисляем разницу времени
            msg = "Осталось " & timeDiff & " секунд в ячейке " & curCell.Address
            Application.StatusBar = msg ' выводим сообщение в строку состояния
             
            curCell.Value = curCell.Value - TimeSerial(0, 0, 1) ' уменьшаем время в ячейке на одну секунду
        Loop
         
        msg = "Осталось 5 минут в ячейке " & curCell.Address
        MsgBox msg ' выводим окно сообщения
         
        curCell.Value = curTime - TimeSerial(0, 5, 0) + TimeSerial(0, 0, 1) ' обновляем время в ячейке на следующую минуту
    Next i
     
    Application.StatusBar = False ' очищаем строку состояния
End Sub

//

Sub StartTimer()
    Dim cell As Range
    For Each cell In Range("C2:C12")
        cell.Value = TimeSerial(0, 0, cell.Value)
    Next cell
    Call Countdown
End Sub

Sub Countdown()
    Dim cell As Range
    For Each cell In Range("C2:C12")
        If cell.Value > 0 Then
            cell.Value = cell.Value - TimeSerial(0, 0, 1)
        Else
            cell.Value = "00:00:00"
        End If
    Next cell
    Application.OnTime Now + TimeValue("00:00:01"), "Countdown"
End Sub

Sub StopTimer()
    On Error Resume Next
    Application.OnTime earliesttime:=Now + TimeValue("00:00:01"), _
        procedure:="Countdown", schedule:=False
End Sub

//

Sub MergeData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
     
    'Выбираем первый лист
    Set ws = ThisWorkbook.Sheets(1)
     
    'Определяем последнюю заполненную строку в первом листе
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
    'Проходим по всем строкам в первом листе
    For i = 2 To lastRow
        'Определяем значение в первом столбце текущей строки
        Dim currentValue As String
        currentValue = ws.Cells(i, 1).Value
         
        'Проходим по всем остальным листам
        For j = 2 To ThisWorkbook.Sheets.Count
            'Определяем последнюю заполненную строку в текущем листе
            lastRow = ThisWorkbook.Sheets(j).Cells(ThisWorkbook.Sheets(j).Rows.Count, 1).End(xlUp).Row
             
            'Проходим по всем строкам в текущем листе
            For k = 2 To lastRow
                'Определяем значение в первом столбце текущей строки
                Dim compareValue As String
                compareValue = ThisWorkbook.Sheets(j).Cells(k, 1).Value
                 
                'Если значения совпадают, то копируем данные из текущей строки в первый лист
                If currentValue = compareValue Then
                    ws.Cells(i, 2).Value = ThisWorkbook.Sheets(j).Cells(k, 2).Value
                    ws.Cells(i, 3).Value = ThisWorkbook.Sheets(j).Cells(k, 3).Value
                    ws.Cells(i, 4).Value = ThisWorkbook.Sheets(j).Cells(k, 4).Value
                    'Добавляем задержку в 1 секунду между итерациями
                    Application.Wait (Now + TimeValue("0:00:01"))
                    Exit For
                End If
            Next k
        Next j
    Next i
End Sub

Option Explicit
Public iTimerRow As Long
Public bMessage As Boolean
Sub Timer()
Dim gCount
    'iTimer = iTimer + 1
    gCount = Now + TimeValue("00:00:01")
    Application.OnTime gCount, "ResetTime"
End Sub
Private Sub ResetTime()
    Dim rCurRange As Range
    Dim iLast As Long
    Dim oSh As Worksheet
    Dim iRow As Long
    Dim iCurRow As Long
    Dim iAnsw As Integer
    Set oSh = ActiveSheet
    iRow = fGetRowByTimer(oSh)
    iLast = oSh.Cells(oSh.Rows.Count, "C").End(xlUp).Row
    If iTimerRow = 0 Then iTimerRow = fGetFirst(oSh, iLast)
    If iTimerRow <= 0 Then GoTo ExitLine
    Set rCurRange = oSh.Range("C" & iTimerRow)
    If bMessage = False Then
        If rCurRange.Value <= TimeSerial(0, 5, 0) Then
            MsgBox "На задание в строке " & iTimerRow & " осталось " & CDate(rCurRange.Value)
            bMessage = True
        End If
    End If
    rCurRange.Value = rCurRange.Value - TimeSerial(0, 0, 1)
    DoEvents
    iAnsw = 6
    If rCurRange.Value <= 0 Then
        iAnsw = MsgBox("Время для задания в строке " & iTimerRow & " истекло." & vbCr & "Приступить к следующему?", vbYesNo)
        bMessage = False
        iTimerRow = 0
    End If
    If iAnsw = 6 Then Call Timer
Exit Sub
ExitLine:
MsgBox "Нету невыполненных заданий"
End Sub
Function fGetRowByTimer(ByRef oSh As Worksheet)
Dim iLast As Integer
Dim iFirst As Integer
    iLast = oSh.Cells(oSh.Rows.Count, "C").End(xlUp).Row
    fGetRowByTimer = fGetFirst(oSh, iLast)
End Function
Function fGetFirst(ByRef oSh As Worksheet, ByVal iLast As Integer)
Dim rRange As Range
Set rRange = oSh.Range("C1", "C" & iLast).Cells
Dim oCell
For Each oCell In rRange.Cells
    'MsgBox Replace(oCell, ":", "")
    If IsNumeric(Replace(oCell, ":", "")) Then
        If UBound(Split(CDate(oCell), ":")) >= 2 Then
            If Replace(Replace(CDate(oCell), ":", ""), "0", "") <> "" Then
                fGetFirst = oCell.Row
                Exit Function
            End If
        End If
    End If
Next oCell
End Function

For iColElem = 1 To oColl.Count

Public oColl As New Collection
Sub Set_Collection()
    For Each oCell In rRange.Cells
    'MsgBox Replace(oCell, ":", "")
        If IsNumeric(Replace(oCell, ":", "")) Then
            If UBound(Split(CDate(oCell), ":")) >= 2 Then
                If Replace(Replace(CDate(oCell), ":", ""), "0", "") <> "" Then
                    iKeyNumber = iKeyNumber - 1
                    fGetFirst = oCell.Row
                    oColl.Add "key" & iKeyNumber, fGetFirst
                End If
            End If
        End If
    Next oCell
End Sub

Public oColl As New Collection