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
    
    s_str = "select * from my_table"
    Application.StatusBar = "Выборка ..."
    
    rst.Open s_str, CN
    
    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
    
    rst.Close
    CN.Close
    
    Set CN = Nothing
    Set rst = Nothing
    
    Application.StatusBar = "Завершен"
    MsgBox ("Данные выгружены")

End Sub

    NewSh.Range("A2").CopyFromRecordset rst

NewSh.Range("A2").CopyFromRecordset rst

    Do While Not rst.EOF
        j = j + 1
        Application.StatusBar = Trim(j)
        For i = 1 To rst.Fields.Count
            NewSh.Cells(j, i).Value = rst.Fields(i - 1).Value
        Next i
        rst.MoveNext
    Loop