VBA macro save SQL query in a csv file

Question

I am working on a VBA macro which connects to my database on SQL Server and run some queries and save the results on CSV files... it works fine just when the queries returns data but i have days where the query doesn't return any results, just an empty table. I made a temporary solution based on checking the date and according it the macro runs that query or no... I want to make it other way now in my code so that i don't need to change the date everytime manually...

I tried these solutions :

If (objMyRecordset.EOF = False) Or (objMyRecordset.BOF = False) Then

Also this

If objMyRecordset.RecordCount <> 0 Then

but the problem is my Recordset is empty because the query doesn't return any rows so it shows me error in objMyRecordset.Open I want to add a line of code like this for example :

'// Pseudo Code
If (the query doesn't return result)  Then 
    ( just the headers will be save on my file )
Else 
    (do the rest of my code)
End If

Here is my code. Any suggestions please ? Thank you very much.

Sub Load_after_cutoff_queryCSV()

    Dim objMyConn As ADODB.Connection
    Dim objMyCmd As ADODB.Command
    Dim objMyRecordset As ADODB.Recordset

    Dim fields As String
    Dim i As Integer

    Set objMyConn = New ADODB.Connection
    Set objMyCmd = New ADODB.Command
    Set objMyRecordset = New ADODB.Recordset

'Open Connection
    objMyConn.ConnectionString = "Provider=SQLOLEDB;Data Source=*****;User ID=*****;Password=*****;"
    objMyConn.Open

'Set and Excecute SQL Command
    Set objMyCmd.ActiveConnection = objMyConn

    objMyCmd.CommandText = "SELECT * FROM [vw_X86_LOAD_AFTER_CUTOFF_REPORT_GAMMA]"

    objMyCmd.CommandType = adCmdText

'Open Recordset
    Set objMyRecordset.Source = objMyCmd

    objMyRecordset.Open

    Workbooks.Open Filename:="C:\Reports\load_after_cutoff_postGamma.csv"
    Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Activate
    ActiveSheet.Range("A2").CopyFromRecordset objMyRecordset

     For i = 0 To objMyRecordset.fields.Count - 1
    Worksheets("load_after_cutoff_postGamma").Cells(1, i + 1) = objMyRecordset.fields(i).name
    Next i

    Workbooks("load_after_cutoff_postGamma.csv").Sheets("load_after_cutoff_postGamma").Cells.EntireColumn.AutoFit

    Workbooks("load_after_cutoff_postGamma.csv").Close SaveChanges:=True
    MsgBox "Your file has been saved as load_after_cutoff_postGamma.csv"

Ralph · Accepted Answer

If you experience problems connecting to your server then this is due to any of the following:

an incorrect connection string
incorrect credentials
the server is not reachable (for example: network cable disconnected)
the server is not up and running

Sending a query to a server which results in an empty recordset is not a reason for an ADODB.Connection to fail.

Here is a little bit of code for you to try and debug the connection in a first step and then the query in a second step:

Option Explicit

Public Sub tmpSO()

Dim strSQL As String
Dim strServer As String
Dim strDatabase As String
Dim OutMail As Outlook.MailItem
Dim rstResult As ADODB.Recordset
Dim conServer As ADODB.Connection
Dim OutApp As Outlook.Application

strServer = "."
strDatabase = "master"

Set conServer = New ADODB.Connection
conServer.ConnectionString = "PROVIDER=SQLOLEDB; " _
    & "DATA SOURCE=" & strServer & ";" _
    & "INITIAL CATALOG=" & strDatabase & ";" _
    & "User ID='UserNameWrappedInSingleQuotes'; " _
    & "Password='PasswordWrappedInSingleQuotes'; "
On Error GoTo SQL_ConnectionError
conServer.Open
On Error GoTo 0

strSQL = "set nocount on; "
strSQL = strSQL & "select  * "
strSQL = strSQL & "from    sys.tables as t "
strSQL = strSQL & "where   t.name = ''; "

Set rstResult = New ADODB.Recordset
rstResult.ActiveConnection = conServer
On Error GoTo SQL_StatementError
rstResult.Open strSQL
On Error GoTo 0

If Not rstResult.EOF And Not rstResult.BOF Then
    ThisWorkbook.Worksheets(1).Range("A1").CopyFromRecordset rstResult
'    While Not rstResult.EOF And Not rstResult.BOF
'        'do something
'        rstResult.MoveNext
'    Wend
Else
    'https://msdn.microsoft.com/en-us/library/windows/desktop/ms675546(v=vs.85).aspx
    Select Case conServer.State
        'adStateClosed
        Case 0
            MsgBox "The connection to the server is closed."
        'adStateOpen
        Case 1
            MsgBox "The connection is open but the query did not return any data."
        'adStateConnecting
        Case 2
            MsgBox "Connecting..."
        'adStateExecuting
        Case 4
            MsgBox "Executing..."
        'adStateFetching
        Case 8
            MsgBox "Fetching..."
        Case Else
            MsgBox conServer.State
        End Select
End If

Set rstResult = Nothing

Exit Sub

SQL_ConnectionError:
MsgBox "Couldn't connect to the server. Please make sure that you have a working connection to the server."

Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .Subject = "Problems connecting to database '" & strDatabase & "' hosted on the server '" & strServer & "'"
    .HTMLBody = "---Automatically generated Error-Email---" & _
            "

Error report from the file '" & _
            "" & ThisWorkbook.Name & _
            "' located and saved on '" & _
            ThisWorkbook.Path & "'.
" & _
            "Excel is not able to establish a connection to the server. Technical data to follow." & "

" & _
            "Computer Name:    " & Environ("COMPUTERNAME") & "
" & _
            "Logged in as:     " & Environ("USERDOMAIN") & "/" & Environ("USERNAME") & "
" & _
            "Domain Server:    " & Environ("LOGONSERVER") & "
" & _
            "User DNS Domain:  " & Environ("USERDNSDOMAIN") & "
" & _
            "Operating System: " & Environ("OS") & "
" & _
            "Excel Version:    " & Application.Version & "
" & _
            "

" & _
            "

---Automatically generated Error-Email---"
    .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing

Exit Sub

SQL_StatementError:
MsgBox "There seems to be a problem with the SQL Syntax in the programming."

Set OutApp = New Outlook.Application
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .Subject = "Problems with the SQL Syntax in file '" & ThisWorkbook.Name & "'."
    .HTMLBody = "" & _
            "---Automatically generated Error-Email---" & _
            "

" & _
            "Error report from the file '" & _
            "" & _
            ActiveWorkbook.Name & _
            "" & _
            "' located and saved on '" & _
            "" & _
            ActiveWorkbook.Path & _
            "" & _
            "'.
" & _
            "It seems that there is a problem with the SQL-Code within trying to upload an extract to the server." & _
            "SQL-Code causing the problems:" & _
            "

" & _
            strSQL & _
            "

" & _
            "---Automatically generated Error-Email---"
    .Display
End With
Set OutMail = Nothing
Set OutApp = Nothing

Exit Sub

End Sub

Note, that the above code clearly distinguishes between (first) connecting to the server and then (afterwards) issuing a query to the server to retrieve some data. Both steps are separated and there is a different error handler for either case.

Furthermore, the above sample code also results in an empty recordset being returned. But the code is able to handle that incident with yet another error handler.

If the connection fails or if the SQL syntax being sent to the server contains error(s) then the above code will automatically generate an error email (using Outlook) with some details for you to check the connection and the SQL syntax.

VBA macro save SQL query in a csv file

Answers (2)

Related Questions