9
\$\begingroup\$

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
\$\endgroup\$
  • 2
    \$\begingroup\$ Consider Range.CopyFromRecordset instead of writing one single cell at a time. \$\endgroup\$ – Mathieu Guindon Apr 29 at 15:49
  • \$\begingroup\$ Hi brother !!! Thank you very much for your help. It worked like a magic. Here is my new pasted code which works !!!!!! Thank you so muach mahn. Saved the day !!! hehehe. Take Care. God Bless You. \$\endgroup\$ – Kaustubh Ursekar Apr 29 at 16:51
  • 1
    \$\begingroup\$ For a VBA new user I recommend one of the excel programming books by John Walkenbach at spreadsheetpage.com. That is how I learned to program VBA. \$\endgroup\$ – pacmaninbw Apr 29 at 16:54
  • \$\begingroup\$ Yes. I have started VBA 3 weeks back by reading documentations. My internship is requiring this skill which I was totally not even asked in interview. lol. I know some C#. So any recommendations for books and websites are warmly and cheerfully welcomed. Please help me know more bros. \$\endgroup\$ – Kaustubh Ursekar Apr 29 at 16:56
10
\$\begingroup\$

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.

\$\endgroup\$
  • \$\begingroup\$ Hi Mathieu. Thanks very much for such detailed post. i shall research this and write a new code and post it here for you guys to review it and then probably you can criticise it further for me to come up with a more sophisticated work. I need to deploy this in production so I wish to be as fine tuned as I could be. Thanks once again. Really appreciate all the details you mentioned here for me !!! \$\endgroup\$ – Kaustubh Ursekar Apr 29 at 17:59
  • \$\begingroup\$ @KaustubhUrsekar that's what this site is all about! =) don't hesitate to post a follow-up with the updated code, in a new "question" (I'd recommend reviewing Rubberduck inspections first though). \$\endgroup\$ – Mathieu Guindon Apr 29 at 18:01
  • \$\begingroup\$ Sure !!. I shall take your description as an answer on this post brother. I shall surely research the stuff you told me and get back to you in a new question. Feeling Happy !! hehehe. \$\endgroup\$ – Kaustubh Ursekar Apr 29 at 18:08
  • \$\begingroup\$ BTW Rubberduck is written in C#, if you're ever looking for a fun & challenging OSS project to contribute to - we need all the help we can get! \$\endgroup\$ – Mathieu Guindon Apr 29 at 18:27
  • \$\begingroup\$ Yes sure mahn. I have developed webpages and websites with C# and .net to be precise. So I would really love to be a "strong" no matter how small or big part of something new and more. Would surely hone my skills with you guys. I wish to learn as much i could. I stepped into computer science field just 4 months back and I see so much in here !!! \$\endgroup\$ – Kaustubh Ursekar Apr 29 at 18:47
3
\$\begingroup\$

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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.