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 ```