Write to EXCEL from SQL DB using VBA script

Question

I have a vba code which takes data from SQL database and dumps it into excel. I see that my query should extract approximately total of 120k records. I monitored this activity and learnt that even after 8 hours of my office time, the query is successful in extracting barely 70k records.

This is frustrating me as I am totally new to VBA. Can you guys help me here by modifying my code?

    Macro1
Private Sub Macro1()
Set objExcel  = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\kursekar\Documents\Work\Apps\ReferralStrApp\StdztnRefRepTrial.xlsx")
objExcel.Visible = True
Dim Conn
Dim RS
Dim SQL
SQL = "WITH cte_REFERRALS_REPORTS(referralnum, refer_from, refer_from_name, refer_from_id, refer_to, refer_to_name, refer_to_id) AS (SELECT referralnum, refer_from, CASE WHEN refer_from_id = 'R' THEN RdicF.refname WHEN refer_from_id = 'P' THEN PdicF.provname END AS refer_from_name, refer_from_id, refer_to, "
SQL = SQL & "CASE WHEN refer_to_id = 'R' THEN RdicT.refname WHEN refer_to_id = 'P' THEN PdicT.provname END AS refer_to_name, refer_to_id FROM referral_t r Left Join refcode_t RdicF ON  r.refer_from = CASE WHEN r.refer_from_id='R' THEN RdicF.refcode ELSE NULL END Left Join refcode_t RdicT ON  r.refer_to = CASE WHEN r.refer_to_id = 'R' THEN RdicT.refcode ELSE NULL END "
SQL = SQL & "Left Join provcode_t PdicF ON r.refer_from  = CASE WHEN r.refer_from_id = 'P' THEN PdicF.provcode ELSE NULL END Left Join provcode_t PdicT ON r.refer_to = CASE WHEN r.refer_to_id = 'P' THEN PdicT.provcode ELSE NULL END ) SELECT chgslipno , a.acctno, patfname, patlname, appt_date, a.enccode, pr.provname "
SQL = SQL & ",a.provcode, rfc.refname, a.refcode, r1.refer_from as r1_ref_from, r1.refer_from_id as r1_ref_from_id, r1.refer_from_name as r1_ref_from_name, a.referral1 as r1_refnum, r2.refer_from as r2_ref_from, r2.refer_from_id as r2_ref_from_id, r2.refer_from_name as r2_ref_from_name,a.referral2, prgrc.provgrpdesc,s.specdesc, a.prov_dept, pos.posdesc,pr.cred "
SQL = SQL & "FROM apptmt_t a Left JOIN patdemo_t p ON a.acctno = p.acctno LEFT JOIN provcode_t pr ON pr.provcode = a.provcode LEFT JOIN refcode_t rfc ON a.refcode = rfc.refcode LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r1 ON a.referral1 = r1.referralnum LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r2 "
SQL = SQL & "on a.referral2 = r2.referralnum LEFT JOIN provgrpprov_t prgrpr on a.provcode = prgrpr.provcode LEFT JOIN provgrpcode_t prgrc on prgrpr.provgrpcode = prgrc.provgrpcode LEFT JOIN specialty_t s on pr.speccode = s.speccode LEFT JOIN poscode_t pos on a.poscode = pos.poscode "
SQL = SQL & "WHERE UPPER(a.enccode) in ('CON','APE','COB','CONZ','HAC','HFUI','MMN','NCG','NCHF','NCPF','NHFU','NMC','NOB','NP','NP15','NPE','NPI','NPOV','NPS','NPSV','NPV','OVN','IMC','NP30') AND UPPER(a.appt_status)='ARR' AND appt_date >= '2017-01-01' "
SQL = SQL & "ORDER BY a.acctno"
Set Conn = CreateObject("ADODB.Connection")
Conn.Open = "Provider=SQLOLEDB.1;Password='25LaurelRoad';User ID='CPSMDIT\kursekar';Data Source='analyzer';Initial Catalog='analyzer_str';Integrated Security=SSPI; Persist Security Info=True;"
Set RS = Conn.Execute(SQL)
Set Sheet = objWorkbook.ActiveSheet
Sheet.Activate
Dim R
R = 2
While RS.EOF = False
  Sheet.Cells(R, 1).Value = RS.Fields(0)
  Sheet.Cells(R, 2).Value = RS.Fields(1)
  Sheet.Cells(R, 3).Value = RS.Fields(2)
  Sheet.Cells(R, 4).Value = RS.Fields(3)
  Sheet.Cells(R, 5).Value = RS.Fields(4)
  Sheet.Cells(R, 6).Value = RS.Fields(5)
  Sheet.Cells(R, 7).Value = RS.Fields(6)
  Sheet.Cells(R, 8).Value = RS.Fields(7)
  Sheet.Cells(R, 9).Value = RS.Fields(8)
  Sheet.Cells(R, 10).Value = RS.Fields(9)
  Sheet.Cells(R, 11).Value = RS.Fields(10)
  Sheet.Cells(R, 12).Value = RS.Fields(11)
  Sheet.Cells(R, 13).Value = RS.Fields(12)
  Sheet.Cells(R, 14).Value = RS.Fields(13)
  Sheet.Cells(R, 15).Value = RS.Fields(14)
  Sheet.Cells(R, 16).Value = RS.Fields(15)
  Sheet.Cells(R, 17).Value = RS.Fields(16)
  Sheet.Cells(R, 18).Value = RS.Fields(17)
  Sheet.Cells(R, 19).Value = RS.Fields(18)
  Sheet.Cells(R, 20).Value = RS.Fields(19)
  Sheet.Cells(R, 21).Value = RS.Fields(20)
  Sheet.Cells(R, 22).Value = RS.Fields(21)
  Sheet.Cells(R, 23).Value = RS.Fields(22)
  RS.MoveNext
  R = R + 1
Wend
RS.Close
Conn.Close
Application.DisplayAlerts = False
'Release memory
Set objFSO = Nothing
Set objFolder = Nothing
Set objFile = Nothing
ActiveWorkbook.Save
'objWorkbook.SaveAs Filename:="C:\\Users\kursekar\Documents\Work\Dailytasks\January\ReferralStrApp\StdztnRefRepTrial.xlsx", FileFormat:=51
Application.DisplayAlerts = True
objWorkbook.Close
objExcel.Workbooks.Close
objExcel.Quit
Workbooks.Close
Set objExcel = Nothing
MsgBox ("Saved")
End Sub

Answer 1

Range.CopyFromRecordset only addresses the [massive] performance issue of traversing an entire recordset row by agonizing row and writing it to a worksheet cell by agonizing cell - all while Excel painstakingly repaints itself every time, fires Worksheet.Change events, and evaluates whether or not recalculations should be happening... between every single worksheet write.

Whenever you programmatically interact with a worksheet, it's a good idea to turn off screen updating, event firing, and make calculations manual to avoid this overhead:

With objExcel
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
End With

And then, don't forget to toggle this Application state back on, and handle runtime errors to make sure it's toggled back on regardless of whether an error occurs or not. Note that any code that involves I/O or a database connection, should handle run-time errors. Right now if the connection times out or if there's a syntax error in that SQL statement, the error is unhandled. I'd recommend something like this:

Public Sub DoSomething()
    On Error GoTo CleanFail
    '...do stuff...
CleanExit:
    '...clean up: restore state, close open connections, etc...
    Exit Sub
CleanFail:
    'log error, warn user, etc.
    Resume CleanExit
End Sub

You are not consistently declaring your variables: the fact that the code can even compile & run with undeclared variables, means you haven't specified Option Explicit at the top of the module. This is a very common beginner trap: VBA is very permissive and lets you do this - doesn't mean you should though. By specifying Option Explicit at the top of every module, you force yourself to declare all variables - which turns a typo into a compile error instead of a very hard-to-diagnose run-time bug.

Activating the active sheet is redundant:

Set Sheet = objWorkbook.ActiveSheet
Sheet.Activate

Rule of thumb, you pretty much never need to Activate anything - especially if you mean to work "in the background" with a hidden application instance. Speaking of which...

Set objExcel  = CreateObject("Excel.Application")

You're hosted in Excel: the Excel type library has to be referenced. There is no reason whatsoever to use CreateObject for this. The New keyword is used for creating objects for which the type is known at compile-time:

Set objExcel = New Excel.Application

Avoid CreateObject whenever possible: it's hitting the Windows Registry, looking up the provided ProgID string, then finds the corresponding class, loads the type from the library, creates an instance, and returns it. Between this:

Set RS = Conn.Execute(SQL)

And this:

Set RS   = CreateObject("ADODB.Recordset") 
RS.Open SQL, Conn

I take Conn.Execute any day. So you're also using late binding for ADODB:

Dim Conn
Dim RS
Dim SQL

Conn and RS should be declared As Object, and SQL should be As String. As it stands, all 3 are implicit Variant. But ideally, you would be referencing the ADODB library, and declare Conn As ADODB.Connection and RS As ADODB.Recordset, creating the connection with Set Conn = New ADODB.Connection.

Note that While...Wend loops were made obsolete when Do While...Loop was introduced, a long time ago: avoid While...Wend - these loops can't be exited without a GoTo jump, but you can early-exit a Do loop with Exit Do.

Watch out for implicit ByVal expressions here:

MsgBox ("Saved")

This takes the "Saved" string literal, evaluates it as an expression (yielding... a string literal), and passes the result ByVal to the MsgBox function. The parentheses are redundant and harmful!

MsgBox "Saved"

Note that this wouldn't compile:

MsgBox ("Saved", vbOkOnly)

Because ("Saved", vbOkOnly) isn't a legal expression that can be evaluated.

Lastly, note that a lot of everything mentioned above (and more) would have been picked up by the Code Inspections of Rubberduck, a VBIDE add-in open-source project I contribute to (along with a merry bunch of fellow VBA reviewers - star us on GitHub if you like!) - I'm obviously biased, but I can't recommend it enough. The project's blog is also a valuable resource for various VBA topics, from late binding to object-oriented programming and modern best-practices.

Answer 2

As per the comment from Mathieu, I modified the code. The code is given below; Works like a charm !!! barely 3 minutes and entire process is done. Thank you for your all help. This is being pasted for information purpose to others. I am new to VBA so its for other beginners like me. Take Care all. BYE !!!!

    Macro1
Private Sub Macro1()

Set objExcel  = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\kursekar\Documents\Work\Apps\ReferralStrApp\StdztnRefRepTrial.xlsx")
objExcel.Visible = False
Set Conn = CreateObject("ADODB.Connection")
Set RS   = CreateObject("ADODB.Recordset") 
Dim SQL
Dim Sconnect
Sconnect = "Provider=SQLOLEDB.1;Password='25LaurelRoad';User ID='CPSMDIT\kursekar';Data Source='analyzer';Initial Catalog='analyzer_str';Integrated Security=SSPI; Persist Security Info=True;"
Conn.Open Sconnect

SQL = "WITH cte_REFERRALS_REPORTS(referralnum, refer_from, refer_from_name, refer_from_id, refer_to, refer_to_name, refer_to_id) AS (SELECT referralnum, refer_from, CASE WHEN refer_from_id = 'R' THEN RdicF.refname WHEN refer_from_id = 'P' THEN PdicF.provname END AS refer_from_name, refer_from_id, refer_to, "
SQL = SQL & "CASE WHEN refer_to_id = 'R' THEN RdicT.refname WHEN refer_to_id = 'P' THEN PdicT.provname END AS refer_to_name, refer_to_id FROM referral_t r Left Join refcode_t RdicF ON  r.refer_from = CASE WHEN r.refer_from_id='R' THEN RdicF.refcode ELSE NULL END Left Join refcode_t RdicT ON  r.refer_to = CASE WHEN r.refer_to_id = 'R' THEN RdicT.refcode ELSE NULL END "
SQL = SQL & "Left Join provcode_t PdicF ON r.refer_from  = CASE WHEN r.refer_from_id = 'P' THEN PdicF.provcode ELSE NULL END Left Join provcode_t PdicT ON r.refer_to = CASE WHEN r.refer_to_id = 'P' THEN PdicT.provcode ELSE NULL END ) SELECT chgslipno , a.acctno, patfname, patlname, appt_date, a.enccode, pr.provname "
SQL = SQL & ",a.provcode, rfc.refname, a.refcode, r1.refer_from as r1_ref_from, r1.refer_from_id as r1_ref_from_id, r1.refer_from_name as r1_ref_from_name, a.referral1 as r1_refnum, r2.refer_from as r2_ref_from, r2.refer_from_id as r2_ref_from_id, r2.refer_from_name as r2_ref_from_name,a.referral2, prgrc.provgrpdesc,s.specdesc, a.prov_dept, pos.posdesc,pr.cred "
SQL = SQL & "FROM apptmt_t a Left JOIN patdemo_t p ON a.acctno = p.acctno LEFT JOIN provcode_t pr ON pr.provcode = a.provcode LEFT JOIN refcode_t rfc ON a.refcode = rfc.refcode LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r1 ON a.referral1 = r1.referralnum LEFT JOIN (SELECT*FROM cte_REFERRALS_REPORTS) r2 "
SQL = SQL & "on a.referral2 = r2.referralnum LEFT JOIN provgrpprov_t prgrpr on a.provcode = prgrpr.provcode LEFT JOIN provgrpcode_t prgrc on prgrpr.provgrpcode = prgrc.provgrpcode LEFT JOIN specialty_t s on pr.speccode = s.speccode LEFT JOIN poscode_t pos on a.poscode = pos.poscode "
SQL = SQL & "WHERE UPPER(a.enccode) in ('CON','APE','COB','CONZ','HAC','HFUI','MMN','NCG','NCHF','NCPF','NHFU','NMC','NOB','NP','NP15','NPE','NPI','NPOV','NPS','NPSV','NPV','OVN','IMC','NP30') AND UPPER(a.appt_status)='ARR' AND appt_date >= '2017-01-01' "
SQL = SQL & "ORDER BY a.acctno"

Set Sheet = objWorkbook.ActiveSheet
Sheet.Activate

RS.Open SQL, Conn
 Sheet.Range("A2").CopyFromRecordset RS

RS.Close
Conn.Close

objExcel.DisplayAlerts = False
'Release memory
'Set objFSO = Nothing
'Set objFolder = Nothing
'Set objFile = Nothing
objWorkbook.Save
objExcel.DisplayAlerts = True
objWorkbook.Close
objExcel.Workbooks.Close
objExcel.Quit

'Set objExcel = Nothing
MsgBox ("Saved")
End Sub

Answer 3

I would try using QueryTable feature, which can take either a Recordset or ConnectionString + SQL. For the sample code below, I have an SQLite database file next to my Excel file. Otherwise, there are no other dependencies.

Private Sub QueryTableSourceAdoRecordSet()
    Dim Driver As String
    Dim Options As String
    Dim Database As String

    Dim adoConnStr As String
    Dim qtConnStr As String
    Dim SQL As String
    Dim QTName As String

    Database = ThisWorkbook.Path + "\" + "ADODBTemplates.db"
    Driver = "SQLite3 ODBC Driver"
    Options = "SyncPragma=NORMAL;LongNames=True;NoCreat=True;FKSupport=True;OEMCP=True;"
    adoConnStr = "Driver=" + Driver + ";" + _
                 "Database=" + Database + ";" + _
                 Options

    qtConnStr = "OLEDB;" + adoConnStr

    SQL = "SELECT * FROM people WHERE id <= 45"

    Dim AdoRecordset As ADODB.Recordset
    Set AdoRecordset = New ADODB.Recordset
    
    With AdoRecordset
        .ActiveConnection = adoConnStr
        .source = SQL
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Open
        Set .ActiveConnection = Nothing
    End With

    Dim Buffer As Excel.Worksheet
    Set Buffer = ActiveSheet
    Dim WSQueryTable As Excel.QueryTable
    Set WSQueryTable = Buffer.QueryTables.Add(Connection:=AdoRecordset, Destination:=Buffer.Range("A1"))
    With WSQueryTable
        .FieldNames = True
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .EnableEditing = True
    End With
    WSQueryTable.Refresh
End Sub

Private Sub QueryTableSourceConnStr()
    Dim Driver As String
    Dim Options As String
    Dim Database As String

    Dim adoConnStr As String
    Dim qtConnStr As String
    Dim SQL As String
    Dim QTName As String

    Database = ThisWorkbook.Path + "\" + "ADODBTemplates.db"
    Driver = "SQLite3 ODBC Driver"
    Options = "SyncPragma=NORMAL;LongNames=True;NoCreat=True;FKSupport=True;OEMCP=True;"
    adoConnStr = "Driver=" + Driver + ";" + _
                 "Database=" + Database + ";" + _
                 Options

    qtConnStr = "OLEDB;" + adoConnStr

    SQL = "SELECT * FROM people WHERE id <= 45"

    Dim Buffer As Excel.Worksheet
    Set Buffer = ActiveSheet
    Dim WSQueryTable As Excel.QueryTable
    Set WSQueryTable = Buffer.QueryTables.Add(Connection:=qtConnStr, Destination:=Buffer.Range("K1"), SQL:=SQL)
    With WSQueryTable
        .FieldNames = True
        .RowNumbers = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SaveData = False
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .EnableEditing = True
    End With
    WSQueryTable.Refresh
End Sub
```