Option Explicit

Private cn As New ADODB.Connection
Private cmd As New ADODB.Command

' Данные для логирования ошибок
Private g_iRowError As Long

Enum StructErr
    seColErr =  1    '"Ошибка"
    seColSheet =  2  '"Лист"
    seColRow =  3    '"Строка с ошибкой"
    seColFunc =  4   '"Функция"
    seColText =  5   '"Текст"
End Enum

'***********************************************************************
'* Открывает коннест к базе
'***********************************************************************
Private Function OpenConnect(sDBPath As String) As Boolean
Dim sErrDesc As String
OpenConnect = False

On Error GoTo labErr

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
cmd.ActiveConnection = cn
OpenConnect = True
Exit Function

labErr:
sErrDesc = Err.Description
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "OpenConnect")
End Function

'***********************************************************************
'* Закрывает коннест к базе
'***********************************************************************
Private Sub CloseConnect()
On Error GoTo labErr

cn.Close

labErr:
Set cn = Nothing
Set cmd = Nothing

End Sub

'***********************************************************************
'* Выполняет запрос подготовленный заранее и возвращает RecordSet
'***********************************************************************
Private Function ExecQueryBaseRS(sSql As String) As ADODB.Recordset
Dim sErrDesc As String
Dim erCur As ADODB.Error

Set ExecQueryBaseRS = Nothing

On Error GoTo labErr

cmd.CommandText = sSql
cmd.Prepared = True
Set ExecQueryBaseRS = cmd.Execute

Exit Function
labErr:

If cn.State <> adStateClosed Then
    cn.RollbackTrans
End If

sErrDesc = "" 'Err.Description & " <-> "

On Error Resume Next

' Get the ADO errors.
If cn.Errors.Count >  0  Then
    For Each erCur In cn.Errors
        sErrDesc = sErrDesc & erCur.Source & ": " & erCur.Description & " | "
    Next erCur
End If
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "ExecQueryBaseRS", cmd.CommandText)
End Function


'***********************************************************************
'* Выводит в активной книге на лист Ошибки сообщения об ошибках
'***********************************************************************
Private Function OutputErrorMessage(sErrMess As String, Optional sSheet As String = "", _
    Optional iRow As Long =  0 , Optional sFunc As String = "", Optional sTxt As String = "")
If shErr Is Nothing Then
    Set shErr = CheckSheetError
End If
On Error GoTo labErr
With shErr
    .Cells(g_iRowError, seColErr).Value = sErrMess
    .Cells(g_iRowError, seColSheet).Value = sSheet
    .Cells(g_iRowError, seColRow).Value = iRow
    .Cells(g_iRowError, seColFunc).Value = sFunc
    .Cells(g_iRowError, seColText).Value = sTxt
End With
g_iRowError = g_iRowError +  1 
Exit Function

labErr:

End Function

'***********************************************************************
'* Проверяет наличие в книге листа для вывода ошибок.
'* Если листа нет - создает
'***********************************************************************
Private Function CheckSheetError() As Worksheet
Dim s As String
On Error GoTo labErr

' Инициализируем номер строки для вывода ошибок
' По номеру строки будем проверять наличие ошибок
' Если больше 2, значит были ошибки и нужно показать лист с ошибками
g_iRowError =  2 

Set CheckSheetError = Sheets("Ошибки")

CheckSheetError.Cells.ClearContents
CheckSheetError.Cells( 1 , seColErr).Value = "Ошибка"
CheckSheetError.Cells( 1 , seColSheet).Value = "Лист"
CheckSheetError.Cells( 1 , seColRow).Value = "Строка с ошибкой"
CheckSheetError.Cells( 1 , seColFunc).Value = "Функция"
CheckSheetError.Cells( 1 , seColText).Value = "Текст"

Exit Function
labErr:
If Err.Number =  9  Then
    With ActiveWorkbook.Sheets.Add
        .Name = "Ошибки"
    End With
    Set CheckSheetError = Sheets("Ошибки")
    Resume Next
End If
End Function

Function GetData17(strPath As String, strField1 As String, strOperator1 As String, strCriterion1 As String, strField2 As String, strOperator2 As String, strCriterion2 As String, strOperator4 As String, strCriterion4 As String, strField3 As String, strOperator3 As String, strCriterion3 As String, strOperator5 As String, strCriterion5 As String, strField5 As String) As Currency


    Dim rst As ADODB.Recordset
    Dim strSQL7 As String
' Сразу устанавливаем значение с ошибкой
    GetData17 = - 1 
    
    ' Устанавливаем соединение с источником данных
    If OpenConnect(strPath) Then
    ' Если соединение установленно, можно запрашивать данные
            '-----------------------------------------------------------------------------------------------------
        strSQL7 = "SELECT count(*) as kolvo from (select distinct [" & strField5 & "] from [Лист1$A3:AM65000] " + _
                  "WHERE [" & strField1 & "] " & strOperator1 & " 'Casco' " + _
                  "and [" & strField2 & "]" & strOperator2 & "#1/1/2011# and [" & strField2 & "] " & strOperator4 & "#1/1/2012# " + _
                  "and [" & strField3 & "]   " & strOperator3 & "#1/1/2011# and [" & strField3 & "] " & strOperator5 & "#1/1/2012#)"
        ' Я не знаю делает ли это драйвер для Ексела, но в стандарте SQL есть конструкция:
        ' Select Count(Distinct имя_поля) As kol_vo_unique from имя_таблицы.
        ' Я к чему, твои два запроса можно переписать на один следующим образом:
'        strSQL7 = "Select count(distinct [" & strField5 & "]) as kolvo from [Лист1$A3:AM65000] " + _
'                  "WHERE [" & strField1 & "] " & strOperator1 & " 'Casco' " + _
'                  "and [" & strField2 & "]" & strOperator2 & "#1/1/2011# and [" & strField2 & "] " & strOperator4 & "#1/1/2012# " + _
'                  "and [" & strField3 & "]   " & strOperator3 & "#1/1/2011# and [" & strField3 & "] " & strOperator5 & "#1/1/2012#"

        ' После подготовки запроса исполняем его
        Set rst = ExecQueryBaseRS(strSQL7)
        If Not rst Is Nothing Then
        ' Если Recordset объект, значит запрос выполнился и можно работать дальше.
            GetData17 = rst.Fields( 0 ).Value
        ' Убираем за собой RecordSet'ы
            rst.Close
            Set rst = Nothing
        Else
        ' Если RecordSet НЕ объект, значит какая-то ошибка и можно смотреть лист "Ошибки" в активной книге
        ' Можно ещё вывести сообщение, что мол ищи описание ошибки :)
        End If
        ' Если соединение открывали, закрываем его
        CloseConnect
    Else
    ' Если соединение не установленно, то нужно смотреть лист "Ошибки" в активной книге
    ' Можно ещё вывести сообщение, что мол ищи описание ошибки :)
    End If
        
End Function

'***********************************************************************
'* Открывает коннест к базе
'***********************************************************************
Private Function OpenConnect(sDBPath As String) As Boolean
Dim sErrDesc As String
OpenConnect = False

On Error GoTo labErr

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1""" ' БЫЛО

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & sDBPath & ";" & "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1""" ' НУЖНО
cmd.ActiveConnection = cn
OpenConnect = True
Exit Function

labErr:
sErrDesc = Err.Description
sErrDesc = Replace(sErrDesc, vbLf, " | ", , , vbTextCompare)
Call OutputErrorMessage(sErrDesc, , , "OpenConnect")
End Function