Sub ExportData()
    Dim CN As ADODB.Connection
    Dim rst As New ADODB.Recordset
    
    Set CN = CreateObject("ADODB.Connection")
    Application.StatusBar = "Подключение к БД..."
    
    
OraConnect:
        UName = "User1"
        PWord = "Pass1"
        SDbName = "Dbname"
        
        s_str = "Provider=OraOLEDB.Oracle;Data Source=" & SDbName & ";User ID=" & UName & ";Password=" & PWord & ";PLSQLRSet=1;"
        CN.ConnectionString = s_str
        CN.Open
    
    CN.Execute "alter session set optimizer_features_enable='11.2.0.3'"
        
    Set MainSh = ActiveWorkbook.Worksheets(1)
    s_str = ActiveSheet.Range("s_query")   ' Получаем запрос
    
    MainSh.Range("A33").Value = Time
    Application.StatusBar = "Выборка ..."
    rst.CursorLocation = 3
    n_max = 1048575
    n_part = 10000
    
    rst.Open s_str, CN
    
    n_sh = 1
    Set NewB = Workbooks.Add()
    n_sh_cnt = NewB.Worksheets.Count
    Set NewSh = NewB.Worksheets(n_sh)
    
    b_exec = True
    n_rec = 0
    n_sh_old = 1
    n_rows = 0
    Do While Not rst.EOF
        If n_sh_old <> n_sh Then
            If n_sh > n_sh_cnt Then
               NewB.Worksheets.Add
               NewB.ActiveSheet.Move After:=NewSh
            End If
            Set NewSh = NewB.Worksheets(n_sh)
            ' Выгружаю шапку
            For i = 1 To rst.Fields.Count
                NewSh.Cells(1, i).Value = rst.Fields(i - 1).Name
            Next i
        End If
        n_sh_old = n_sh
        n_rows = n_rows + n_part
        If n_rows > n_max Then
           n_rec = n_part - (n_max - n_rows)
           n_rows = 0
           n_sh = n_sh + 1
        Else
           n_rec = n_part
        End If
        ' Выгружаю данные
        NewSh.Range("A2").CopyFromRecordset rst, n_rec
    Loop
    
    rst.Close
    CN.Close
    
    Set CN = Nothing
    Set rst = Nothing
    
    Application.StatusBar = "Завершен"
    MainSh.Range("A34").Value = Time
    MsgBox ("Данные выгружены")
End Sub

    n_max = 1048575
    rst.Open s_str, CN

    n_file = 0    
    Do While Not rst.EOF
        n_file = n_file + 1
        Set NewB = Workbooks.Add()
        Set NewSh = NewB.Worksheets(1)
        
        ' Выгружаю шапку
        For i = 1 To rst.Fields.Count
            NewSh.Cells(1, i).Value = rst.Fields(i - 1).Name
        Next i
        
        ' Выгружаю данные
        NewSh.Range("A2").CopyFromRecordset rst, n_max
        
        fn_xls = trim(n_file) & ".xlsb"
        
        If Len(Dir(fn_xls)) <> 0 Then ' файл существует
           res1 = MsgBox("Файл существует, перезаписать ? " & fn_xls, (vbYesNo + vbQuestion + vbSystemModal), "Сохранение файла")
           If res1 = vbYes Then 'нажата кнопка "Да" (Yes)
                Application.DisplayAlerts = False
                NewB.SaveAs Filename:=fn_xls, FileFormat:=xlExcel12, CreateBackup:=False
                Application.DisplayAlerts = True
                NewB.Close
           Else
              Exit Sub
           End If
        Else
            NewB.SaveAs Filename:=fn_xls, FileFormat:=xlExcel12, CreateBackup:=False
            NewB.Close
        End If
    Loop
    
    rst.Close
    CN.Close
    
    Set CN = Nothing
    Set rst = Nothing
    
    Application.StatusBar = "Завершен"
    MsgBox ("Данные выгружены, создано файлов - " & Trim(n_file))