Function ddd(sdate As Date, hours As Integer, tbeg As Integer, tend As Integer, pbeg As Integer, pend As Integer, tip As Integer)
    Dim dif_Minute As Long
    With Sheets("Праздники")
        arr = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    Set slov = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        slov.Item(arr(i, 1)) = i
    Next
    dif_Minute = Minute(sdate) / 1440
    If dif_Minute > 0 Then sdate = sdate + 1 / 24 - dif_Minute
    
    Do While hours > 0
        sdate = sdate + 1 / 24
        If Not slov.exists(sdate) Then
            If Weekday(sdate, 2) <= tip Then
                If Hour(sdate) >= tbeg And Hour(sdate) < tend And Not (Hour(sdate) >= pbeg And Hour(sdate) < pend) Then
                    hours = hours - 1
                End If
            End If
        End If
        
    Loop
    ddd = sdate - dif_Minute
End Function

Sub CompareMacro()
    Dim FilesToOpen
    Dim x As Integer
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
   'вызываем диалог выбора файлов для импорта
    OpenPath = ThisWorkbook.Path
    ChDrive OpenPath
    ChDir OpenPath
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge") '.OpenPath = "C:\"
 
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
     
    'проходим по всем выбранным файлам
    Dim s(1 To 2) As String
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWb = Workbooks.Open(Filename:=FilesToOpen(x))
        'For Each pj In Application.VBE.VBProjects
        Set pj = ActiveWorkbook.VBProject
            For Each vbcomp In pj.VBComponents
                If Not vbcomp Is Nothing Then
                    N = vbcomp.CodeModule.CountOfLines
                    If N > 0 Then
                        s(x) = s(x) + vbCrLf + "*****" + vbcomp.CodeModule.Name + "*****" + vbCrLf
                        s(x) = s(x) + vbcomp.CodeModule.Lines(1, N)
                    End If
                End If
            Next
        'Next
        importWb.Close False 'savechanges:=True
        x = x + 1
    Wend
    If s(1) <> s(2) Then [D1] = "Не совпадает" Else [D1] = "Совпадает"
    s3 = Split(s(1), vbCrLf)
    'cr = 1
    Columns("A:C").ClearContents
    arr1 = Range("A1:A" & UBound(s3) + 1)
    For i = 0 To UBound(s3)
        arr1(i + 1, 1) = s3(i)
    Next
    Range("A1:A" & UBound(arr1)) = arr1
    
    s4 = Split(s(2), vbCrLf)
    'cr = 1
    arr2 = Range("B1:B" & UBound(s4) + 1)
    For i = 0 To UBound(s4)
        arr2(i + 1, 1) = s4(i)
    Next
    Range("B1:B" & UBound(arr2)) = arr2
    If UBound(arr1) > UBound(arr2) Then lim = UBound(arr2) Else lim = UBound(arr1)
    For i = 1 To lim
        If arr1(i, 1) <> arr2(i, 1) Then Cells(i, "C") = 1
    Next
    Application.ScreenUpdating = True
    MsgBox "Процесс проверки успешно завершен!"
End Sub