Sub sql_query()

Dim Regn, nPer, i, j As Integer
Dim Baldate, stSQL, nOtch As String
Dim Flag As Boolean

Dim wsSheet As Worksheet
Dim wsBook As Workbook
Dim rnStart As Range
     
On Error Resume Next

'initial data
Regn = ThisWorkbook.Worksheets("CrystalSphere").Range("C4")
nPer = ThisWorkbook.Worksheets("CrystalSphere").Range("F4")

'начало цикла по датам
Application.DisplayAlerts = False
    For i =  1  To nPer
        Set Baldate = ThisWorkbook.Worksheets("CrystalSphere").Cells( 7 ,  16  + i)
        Set wsBook = Workbooks.Add
            Do While wsBook.Sheets.Count >  1     'удаляем все листы, кроме 1
                wsBook.Worksheets( 1 ).Delete
            Loop
    'цикл по выводу отчетных форм
        For j =  1  To  4 
                Select Case j '1=101, 2=102, 3=134, 4=135
                    Case j =  1 : nOtch = "101"
                    Case j =  2 : nOtch = "102"
                        If Right(Baldate,  1 ) <>  3  _
                            Or Right(Baldate,  1 ) <>  6  _
                            Or Right(Baldate,  1 ) <>  9  _
                            Or Right(Baldate,  2 ) <>  12  Then: Exit For
                    Case j =  3 : nOtch = "134"
                    Case j =  4 : nOtch = "135"
                End Select
            Set wsSheet = wsBook.Worksheets.Add
            Set rnStart = wsSheet.Range("A2")
            'query string
            stSQL = ThisWorkbook.Worksheets("CrystalSphere").Cells( 5  + j,  14 )
            stSQL = Replace(Replace(stSQL, "[%regn%]", Regn), "[%date%]", Baldate)
            'function call
            Add_Results_Of_ADO_Recordset stSQL, wsSheet, rnStart, True
            'worksheet name & propreties

            wsSheet.Name = Regn & "_" & nOtch & "_" & Baldate
            wsSheet.Columns("C:O").NumberFormat = "#,##0.00"
        Next j
    Next i
Application.DisplayAlerts = True
End Sub

Sub Add_Results_Of_ADO_Recordset(stSQL As String, wsSheet As Worksheet, rnStart As Range, Flag As Boolean)
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim k As Integer
Dim IC, DS, LG, PS, stADO As String

On Error Resume Next
'выбор вида подключения
If ThisWorkbook.Worksheets("CrystalSphere").CheckBox4.Value = True Then
        IC = ThisWorkbook.Worksheets("CrystalSphere").Cells( 7 ,  3 )
        DS = ThisWorkbook.Worksheets("CrystalSphere").Cells( 8 ,  3 )
        'Initial Catalog (IC)   = SQL Database  (Bank_RUR/Bank_RUS);
        'Data Source     (DS)   = SQL Server    (M2010012000501\SQLEXPRESS)
            stADO = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;" & _
            "Initial Catalog=" & IC & ";" & _
            "Data Source=" & DS
Else
        IC = ThisWorkbook.Worksheets("CrystalSphere").Cells( 7 ,  3 )   'Initial сatalog
        DS = ThisWorkbook.Worksheets("CrystalSphere").Cells( 8 ,  3 )   'Data source
        LG = ThisWorkbook.Worksheets("CrystalSphere").Cells( 9 ,  3 )   'Login
        PS = ThisWorkbook.Worksheets("CrystalSphere").Cells( 10 ,  3 )  'Password
            
            stADO = "Provider=SQLNCLI;Server=" & DS & ";Database=" & IC & ";Uid=" & LG & "; Pwd=" & PS & ";"
                
End If
      
    Set cnt = New ADODB.Connection
        With cnt
            .CursorLocation = adUseClient
            .Open stADO
            .CommandTimeout =  0 
            Set rst = .Execute(stSQL) 'тут ошибка, если в базе нет!!!!!!!!!!!
        End With
    'Fields name
    If Flag = True Then
        For k =  0  To rst.Fields.Count -  1 
            wsSheet.Cells(rnStart.Row -  1 , rnStart.Column + k).Value = rst(k).Name
        Next k
    End If
    'Here we add the Recordset to the sheet from A1
    rnStart.CopyFromRecordset rst
    'Cleaning up
        rst.Close
        cnt.Close
    Set rst = Nothing
    Set cnt = Nothing
End Sub