Kdtyjb

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:UserskursekarDocumentsWorkAppsReferralStrAppStdztnRefRepTrial.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='CPSMDITkursekar';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:\UserskursekarDocumentsWorkDailytasksJanuaryReferralStrAppStdztnRefRepTrial.xlsx", FileFormat:=51

Application.DisplayAlerts = True

objWorkbook.Close

objExcel.Workbooks.Close

objExcel.Quit

Workbooks.Close

Set objExcel = Nothing

MsgBox ("Saved")

End Sub

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.

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:UserskursekarDocumentsWorkAppsReferralStrAppStdztnRefRepTrial.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='CPSMDITkursekar';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

```