Option Explicit 

Sub RunQuery(SQLString As String, CnnStr As String, Er As Boolean, _
       Optional ResultRange As Range = Nothing, Optional IncludeHdr As Boolean = False)
Dim CN As ADODB.Connection, Cmd As ADODB.Command, Rs As ADODB.Recordset
Dim I As Byte, F As Field
On Error Resume Next
  Er = False
  Set CN = New ADODB.Connection
  CN.ConnectionString = CnnStr
  CN.Open
  If Err.Number <> 0 Then
    MsgBox "Ошибка подключения к базе данных: " & Chr(13) & Chr(13) & Err.Description, vbCritical
    Er = True
    Exit Sub
  End If       

  Set Cmd = New ADODB.Command
  Set Cmd.ActiveConnection = CN
  Cmd.CommandText = SQLString
  Cmd.CommandType = adCmdText
  CN.Errors.Clear
  If ResultRange Is Nothing Then
    Cmd.Execute
    If Err.Number <> 0 Then
   MsgBox "Ошибка при выполнении запроса: " & Chr(13) & Err.Description, vbCritical
      Er = True
    End If
  Else
    Set Rs = New ADODB.Recordset
    Set Rs.Source = Cmd
    Rs.Open
    If Err.Number = 0 Then
   If IncludeHdr Then
     I = 0
     For Each F In Rs.Fields
       ResultRange.Offset(0, I).Value = F.Name
       I = I + 1
    Next F
     With Range(ResultRange, ResultRange.Offset(0, I))
       .HorizontalAlignment = xlCenter
       .Font.Bold = True
     End With
     ResultRange.Offset(1, 0).CopyFromRecordset Rs
   Else
     ResultRange.CopyFromRecordset Rs
   End If
    Else
   MsgBox "Ошибка при выполнении запроса: " & Chr(13) & Err.Description, vbCritical
   Er = True    End If
    Rs.Close
  End If
  CN.Close
  Set F = Nothing
  Set Rs = Nothing
  Set Cmd = Nothing
  Set CN = Nothing
End Sub