aDate = CDate("01.01.2023")
            zDate = CDate("31.12.2024")
            
For i = lLastRow To 8 Step -1
        If Not IsEmpty(Cells(i, Beg)) Then

                If Cells(i, Beg) < aDate Then Cells(i, Beg).Interior.ColorIndex = 6
                If Cells(i, Beg) > zDate Then Cells(i, Beg).Interior.ColorIndex = 3

        End If

Next i

Cells(i, NumPP).NumberFormat = "0.0"

    Plus = dtmin
    For k = 10 To dtDiff + 10
        With Cells(1, k)
            .Value = Plus
            .NumberFormat = "m/d/yyyy"
        End With
    Plus = Plus + 1
    Next

Sub Start()

    Dim i As Integer, j As Integer, a As Long, x As New Collection, y As Range, N As Long
    N = CommandButton.Application.Caller
    
    With Sheets(N)
...

Dim Ws As Worksheet
.... 
If Ws.Cells(1, 1).Name = "first" Then Ws.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

ActiveSheet.PageSetup.PrintArea = Range("first", "end").Address

ActiveSheet.PageSetup.PrintArea = Range("first", Cells(Cells.Name = "end").Offset(1, 2)).Address

Set Ma = Range("end").MergeArea
'MsgBox Ma.Address
Set rngEnd = Ma.Cells(Ma.Rows.Count, Ma.Columns.Count)
'MsgBox rngEnd.Address
ActiveSheet.PageSetup.PrintArea = Range("first", rngEnd).Address

Option Explicit

Public Sub AAA()
    Dim pIF As New WIA.ImageFile
    Dim pV As WIA.Vector
    Dim IP As New WIA.ImageProcess
    Dim last As Long
    Dim iRow, iCol As Long
    Dim h As Single, w As Single
    Dim FileName As String
    Dim c As Range, i&
    Dim lr As Long
    Dim lAllCnt As Long 'количество итераций
    Const lMaxQuad As Long = 20 'длина статус-бара
    
FileName = Application.GetOpenFilename _
    ("Рисунки bmp,*.bmp,Файлы Excel,*.xls*,Текстовые файлы txt,*.txt,Рисунки jpg,*.jpg", , "Выбор файла")
    pIF.LoadFile FileName
    
    'pIF.LoadFile "c:\кекс.jpg"
    Application.ScreenUpdating = False

    Dim sh As Worksheet: Set sh = ActiveSheet
    sh.UsedRange.Interior.ColorIndex = 0

    IP.Filters.Add IP.FilterInfos("Scale").FilterID
    IP.Filters(1).Properties("MaximumWidth") = CLng(pIF.Width)
    IP.Filters(1).Properties("MaximumHeight") = CLng(pIF.Height)
    
    'last = CLng(pIF.Width# * CDbl(pIF.Height) / CDbl(pIF.Width))
    
    Set pIF = IP.Apply(pIF)
    Set pV = pIF.ARGBData
    'Stop
    
    For iRow = 1 To pIF.Height
    For iCol = 1 To pIF.Width
        
            'Cells(iRow, iCol).Interior.Color = GetColor(pV, pIF.Width, iCol, iRow)
        i = GetColor(pV, pIF.Width, iCol, iRow)
 
            Cells(iRow, iCol).Value = Format$(i Mod 256, "000\,") & Format$((i Mod 65536) \ 256, "000\,") & Format$(i \ 65536, "000")     
            
    Next iCol
   
Application.StatusBar = "Выполнено: " & Int(100 * iRow / iCol) & "%" & String(CLng(lMaxQuad * iRow / iCol), ChrW(9724)) & String(lMaxQuad - CLng(lMaxQuad * iRow / iCol), ChrW(9723))
    
    Next iRow

    'Очищаем статус-бар от значений после выполнения
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Public Function GetColor(ByVal inVector As WIA.Vector, ByVal imgWidth As Long, ByVal xPixelID As Long, ByVal yPixelID As Long) As Long
    Dim ToHex As String, vCount As Long
    ToHex = VBA.Hex$(inVector(xPixelID + (yPixelID - 1&) * imgWidth))
    vCount = VBA.Len(ToHex)
    If vCount < 8 Then ToHex = VBA.String$(8 - vCount, "0") & ToHex
    GetColor = VBA.RGB(CInt("&H" & VBA.Mid$(ToHex, 3, 2)), CInt("&H" & VBA.Mid$(ToHex, 5, 2)), CInt("&H" & VBA.Mid$(ToHex, 7, 2)))
End Function

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Книги Excel", _
                     Optional ByVal FilterExtention As String = "*.xls*") As String

    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
    End With
End Function

Sub Zebra()


Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet


lc = Cells.SpecialCells(xlLastCell).Column
lr = Cells(Rows.Count, 1).End(xlUp).Row


'For f = 10 To lr
    If Cells(12, 1).Interior.Pattern = xlSolid Then
            Cells.Select
                With Selection.Interior
                 .Pattern = xlNone
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                 End With
    Else

            For I = 10 To lr Step 2
                If Not IsEmpty(Cells(I, 6)) Then
                    With Range(Cells(I, 1), Cells(I, lc))
                        .Interior.ThemeColor = xlThemeColorAccent1
                        .Interior.TintAndShade = 0.799981688894314
                    End With
                End If
            Next I

    End If
'f=f+1
'Next f

End With
 Range("C1").Select
Application.ScreenUpdating = True
End Sub