Private Const INVALID_FILE_ATTRIBUTES& = -1

' возвращает перечень атрибутов файла по его имени
' в случае ошибки (файл не существует, нет прав доступа, файл блокирован(?), etc) 
' возвращает INVALID_FILE_ATTRIBUTES
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
    ByVal lpFileName As String _
    ) As Long

Public Sub CompareCO2WEB()
  'объект Excel создадим только если есть файлы для обработки
    'Dim xlApp As New Excel.Application
  Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook, xlBook1 As Excel.Workbook
    Dim xlSheet As Excel.Worksheet, xlSheet1 As Excel.Worksheet
    Dim sMes As String, sYear As String, sFilfer() As String, vt As String, dor As String, dor_p As String
    Dim a As Integer, h As Integer, r As Integer, c As Integer, p As Long
  Dim myPath As String  
    
  
  myPath = GetPath() ' ументшим количество вызовов GetPath()
    InFolder$ = myPath & "\input\XLS\"
    f$ = Dir(InFolder$ & "*.xls")
    
  If StrComp("", f) = 0 Then Exit Sub
  
  Set db = DBEngine.OpenDatabase(myPath & "\base.mdb")
  Set xlApp = New Excel.Application

  Do 
    'Set xlBook = GetObject(InFolder$ & f$)
    Set xlBook = xlApp.Workbooks.Open(InFolder$ & f$) ' открыть файл СРАЗУ в экселе будет быстрее, чем по ассоцииации расширения
    Set xlSheet = xlBook.WorkSheets(1)
    
    'sMes = Left(Right(Trim(xlSheet.Cells(2, 1)), 7), 2)
    'sYear = Right(Right(Trim(xlSheet.Cells(2, 1)), 7), 4)
    sYear = Right$(RTrim$(xlSheet.Cells(2, 1)), 7)
    sMes = Left$(sYear, 2)
    sYear = Right$(sYear, 4)
    
    sFilfer() = Split(Trim(xlSheet.Cells(4, 1)), " ")
    
    For h = LBound(sFilfer) To UBound(sFilfer)
      'Select Case Trim(sFilfer(h))
      Select Case sFilfer(h) 'элементы sFilter() получены сплитом по пробелу, - Trim уже лишний 
        Case "е1:": vt = sFilfer(h + 1):    h = h + 1 'экономим один шаг цикла :)
        Case "у2:": dor_p = sFilfer(h + 1): h = h + 1
        Case "в:":  dor = sFilfer(h + 1):   h = h + 1
      End Select
    Next h
    
    vt = db.OpenRecordset("select VT_FILE from VT where VT_FN='" & vt & "'")(0)       
    dor = db.OpenRecordset("select DOR from DOR where DOR_FN='" & dor & "'")(0)         
    dor_p = db.OpenRecordset("select DOR from DOR where DOR_FN='" & dor_p & "'")(0)     
    
    sPathCO2$ = myPath & "\output\" & sMes & "_" & sYear & "\"
    sFile$ = sMes & Right(sYear, 2) & vt & "_" & Left(dor, 2) & "in" & Left(dor_p, 2) & ".xls"
    
    If GetFileAttributes(sPathCO2$ & sFile) <> INVALID_FILE_ATTRIBUTES Then
    
      sPathWEB$ = myPath & "\analysis\CompareCO2WEB\" & sMes & "_" & sYear & "\"
    
    ' REM на самом деле нам не интересно существует ли папка, 
    ' REM т.к. двумя строками ниже мы проверяем наличие определённого файла в этой папке
    ' REM и только при его наличии что-то делаем.
    'If Len(Dir(sPathCO2$, vbDirectory)) <> 0 Then
      'sFile$ = sMes & Right(sYear, 2) & vt & "_" & Left(dor, 2) & "in" & Left(dor_p, 2) & ".xls"
      'If Len(Dir(sPathCO2$ & "\" & sFile$)) <> 0 Then
        
      My_MkDir (sPathWEB$)
      FileCopy sPathCO2$ & sFile$, sPathWEB$ & sFile$
      
      'Set xlBook1 = GetObject(sPathWEB$ & sFile$)
      Set xlBook1 = xlApp.Workbooks.Open(sPathWEB$ & sFile$) ' открыть файл в СРАЗУ экселе будет быстрее, чем по ассоцииации расширения
      Set xlSheet1 = xlBook1.WorkSheets(1)
      
      a = 1  
      s = 8  
      c = 4  
      Do While a <= 14
        If a = Trim(xlSheet1.Cells(s, c)) Then
          For r% = 1 To 30
            With xlSheet1.Cells(r% + s, c)
            ' REM явные преобразования к Long в данном случае имют смысл только если 
            ' REM в ячейках содержатся дробные числа, которые надо округлить
            ' REM если там только целые числа, то можно записать короче
            ' p = Val(xlSheet.Cells(r% + s, c)) - Val(.Value)
            p = CLng(IIf(xlSheet.Cells(r% + s, c) = "", "0", xlSheet.Cells(r% + s, c))) - CLng(IIf(.Value = "", "0", .Value))
            Select Case p
              Case Is > 0
                .Interior.Color = 255              
                .NoteText ("1753")
              Case Is < 0
                .Interior.Color = 65535              
                .NoteText ("1752")
            End Select
            ' REM тут преобразование к строке вылядит неуместным, учитывая, что формат у ячейки "общий"
            ' REM вполне достаточно .Value = IIf(p = 0, "", Abs(p))
            .Value = IIf(p = 0, "", CStr(Abs(p)))
            End With
          Next r%
          a = a + 1
        End If
        c = c + 1
      Loop
      'xlBook1.Windows(1).Visible = True 'зачем делать файл видимым перед закрытием - так и не понял...
      Set xlSheet1 = Nothing
      xlBook1.Close True: Set xlBook1 = Nothing
      'End If
    'End If
    
    End If
    Set xlSheet = Nothing
    xlBook.Close: Set xlBook = Nothing
    f$ = Dir
  Loop Until StrComp("", f$) = 0
  
  db.Close: Set db = Nothing
  xlApp.Quit: Set xlApp = Nothing
  
End Sub