Sub test300()
    Dim Arr1()
    Dim Arr2()
    Dim i&
    Dim x&
Application.ScreenUpdating = False

            With Sheets(1)
                Arr1 = .Range(.Cells(1, 1), .Cells(300000, 1)).Value
                Arr2 = .Range(.Cells(1, 2), .Cells(300000, 2)).Value
            End With

                For i = 1 To 300000
                    For x = 1 To 300000
                        If Arr1(i, 1) = Arr2(x, 1) Then
                            ActiveSheet.Cells(x, 3) = "Ok"
                        End If
                    Next
                Next

Application.ScreenUpdating = True
End Sub

Sub Cycle_with_Massive_zalivka_bez_cycles()    Dim Naimenovanie As Variant
    Dim Zalivka As Variant
    Dim MyArray1() As Variant
    Dim MyArray2() As Variant
    Dim j%, i%
    Set Analiz = Sheets(Лист4.Name)
    Set TDSheet = Sheets(Лист3.Name)
    Application.ScreenUpdating = False
   
            With TDSheet
                MyArray1 = .Range(.Cells(1, 2), .Cells(7948, 2)).Value
            End With
 
           With TDSheet
                MyArray2 = .Range(.Cells(1, 12), .Cells(7948, 12)).Value
            End With
 '        Cycle J
            For j = 1 To 7895
                Naimenovanie = Analiz.Cells(j, 2)
                Summa = Analiz.Cells(j, 13)
                Zalivka = Analiz.Cells(j, 2).Interior.Color
                Data = Analiz.Cells(j, 16)
                Nomer_Akta = Analiz.Cells(j, 17)
                Otpravka_s_reestrom = Analiz.Cells(j, 18)
                Na_soglasovanii = Analiz.Cells(j, 19)
               Ispolnitel = Analiz.Cells(j, 20)
                V_Rabote = Analiz.Cells(j, 21)
                Vozvrat = Analiz.Cells(j, 22)
                Primech = Analiz.Cells(j, 23)
'        Cycle i
                    For i = 1 To 7948
                        If MyArray1(i, 1) = Naimenovanie And MyArray2(i, 1) = Summa Then
                            TDSheet.Cells(i, 2).Interior.Color = Zalivka
                            TDSheet.Cells(i, 15) = Data
                            TDSheet.Cells(i, 16) = Nomer_Akta
                            TDSheet.Cells(i, 17) = Otpravka_s_reestrom
                            TDSheet.Cells(i, 18) = Na_soglasovanii
                            TDSheet.Cells(i, 19) = Ispolnitel
                            TDSheet.Cells(i, 20) = V_Rabote
                            TDSheet.Cells(i, 21) = Vozvrat
                            TDSheet.Cells(i, 22) = Primech
                        Exit For
                        End If
                    Next i
           Next j
        Application.ScreenUpdating = True
End Sub

For i = 1 To 167
Naimenovanie = Sheets(2).Cells(i,2)
Summa = Sheets(2).Cells(i,9)

For k = 1 To 180
Naimenovanie2 = Sheets(1).Cells(k,2)
Summa2 = Sheets(1).Cells(k,13)
If  Naimenovanie = Naimenovanie2 And Summa = Summa2 Then
Sheets(1).Cells(k,2).Interior.Color = 15773696
Exit For
End If
Next k
Next i

Sub Cycle_with_Massive_zalivka_bez_cycles()
    Dim Naimenovanie As Variant
    Dim i%, j%
    Set Analiz = Workbooks("Vecher.xlsm").Sheets(Лист1.Name)
    Set TDSheet = Workbooks("ArtAlex.xlsx").Sheets("стр2 (2)")
    Application.ScreenUpdating = False

    For j = 1 To 238

'       Загружаем данные в массив

            With Analiz
                Naimenovanie = .Range(.Cells(1, 2), .Cells(21, 2)).Value
                Serial = .Range(.Cells(1, 7), .Cells(21, 7)).Value
                Postavchik = .Range(.Cells(1, 3), .Cells(21, 3)).Value
                Nomer_Dogovora = .Range(.Cells(1, 5), .Cells(21, 5)).Value
                Data_Dogovora = .Range(.Cells(1, 6), .Cells(21, 6)).Value
                Nomer_Scheta = .Range(.Cells(1, 11), .Cells(21, 11)).Value
                Data_Scheta = .Range(.Cells(1, 12), .Cells(21, 12)).Value
                Nomer_Nacladnaya = .Range(.Cells(1, 4), .Cells(21, 4)).Value
                Summa = .Range(.Cells(1, 13), .Cells(21, 13)).Value
            End With

'     Кидаем данные из массива в шаблон TDSheet

            For i = 1 To 21
                            TDSheet.Cells(i + 3, 3) = Naimenovanie(i, 1)
                            TDSheet.Cells(i + 3, 4) = Serial(i, 1)
                            TDSheet.Cells(i + 3, 7) = Postavchik(i, 1)
                            TDSheet.Cells(i + 3, 8) = Nomer_Dogovora(i, 1)
                            TDSheet.Cells(i + 3, 9) = Data_Dogovora(i, 1)
                            TDSheet.Cells(i + 3, 10) = Nomer_Scheta(i, 1)
                            TDSheet.Cells(i + 3, 11) = Data_Scheta(i, 1)
                            TDSheet.Cells(i + 3, 12) = Nomer_Nacladnaya(i, 1)
                            TDSheet.Cells(i + 3, 17) = Summa(i, 1)
             Next i
'        Удаляем 21 строку с данными

             For r = 1 To 21
                Analiz.Rows(1).Delete
             Next r

'        Сохраняем  шаблон с именем Иванов и время текущее
           
                    Workbooks("ArtAlex.xlsx").Activate
                    strPath = "C:\Users\Отчеты Еженедельные\февраль"
                    On Error Resume Next
                    x = GetAttr(strPath) And 0
                    If Err = 0 Then
                        strDate = Format(Now, "hh-mm-ss-ms")
                        FileNameXls = strPath & "\" & "Иванов " & " " & strDate & ".xlsx"
                        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
                    Else
                        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
                    End If
    Next j
        Application.ScreenUpdating = True
End Sub

Sub главная процедура()
...
код
...
        Select Case OneDay
            Case Is < Zima2013: Call Handler1
            Case Is >= Zima2013 And OneDay < Vesna2014: Call Handler2
            Case Is >= Vesna2014 And OneDay < Zima2014: Call Handler1
            Case Is >= Zima2014 And OneDay < Vesna2015: Call Handler2
            Case Is >= Vesna2015: Call Handler1:
        End Select
End sub

Sub Handler1()
                For i = Start To Finish
                    StartTimeAM = i
                    If Cells(i, 2) > OpenStart Then Exit For Else: StartTimeAM = 0
                Next i
                For i = Start To Finish
                    If Cells(i, 2) > OpenFinish Then Exit For
                    FinishTimeAM = i
                Next i
                    If StartTimeAM = 0 Then Cells(NextRow, 10) = [b1] _
                    Else: Cells(NextRow, 10) = WorksheetFunction.Average(Range("C" & StartTimeAM & ":C" & FinishTimeAM))
                For i = Finish To Start Step -1
                    StartTimePM = i
                    If Cells(i, 2) < CloseStart Then Exit For Else: StartTimePM = 0
                Next i
    
                For i = StartTimePM To Finish
                    If Cells(i, 2) > CloseFinish Then Exit For
                    FinishTimePM = i
                Next i
                    Cells(NextRow, 13) = WorksheetFunction.Average(Range("F" & StartTimePM & ":F" & FinishTimePM))
End Sub

Sub Cycle_with_Massive_zalivka()    
    Dim Naimenovanie As String
    Dim Suma As Variant
    Dim Zalivka As Variant
    Dim MyArray1(1 To 13390) As Variant
    Dim MyArray2(1 To 13390) As Variant
    Application.ScreenUpdating = False
 
            For i = 1 To 13390
                MyArray1(i) = Sheets(Лист3.Name).Cells(i, 2)
            Next i
 
            For i = 1 To 13390
                MyArray2(i) = Sheets(Лист3.Name).Cells(i, 13)
            Next i
           
                For j = 1 To 273
                Naimenovanie = Sheets(Лист4.Name).Cells(j, 2)
                Suma = Sheets(Лист4.Name).Cells(j, 13)
                Zalivka = Sheets(Лист4.Name).Cells(j, 13).Interior.Color
                    For i = 1 To 13390
                    If MyArray1(i) = Naimenovanie And MyArray2(i) = Suma Then
                    Sheets(Лист3.Name).Cells(i, 13).Interior.Color = Zalivka
                    End If
                Next i
        Next j
        Application.ScreenUpdating = True
End Sub

Sub AvgRangeMy()
    AvgRange = Sheets(Лист1.Name).UsedRange.Columns(3)
        For Each x In AvgRange
            If x >= "10:00:01" And x <= "10:00:05" Then
                Range("G3") = WorksheetFunction.Average(Range("D2:D98"))
                Exit For
            End If
        Next
End Sub