Solved Iterate Through 2 Recordsets + Excel (1 Viewer)

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
This is the next step in a questions that I was able to resolve on this forum.

My goal is to iterate through a recordset, and inside that recordset, reference a second recordset and output the results to an existing excel file.
Example: If the department is active (first recordset) output all transactions for that department (second recordset) to an existing excel file.

Code:
Private Sub Command47_Click()

'BOF checks if current record position is before the first record
'EOF checks if current record position is after the last record
'If BOF and EOF both return TRUE, then the Table has no record
'rs.MoveFirst ‘makes the first record the current record, in case current record is not the first record


'Error handling
    'On Error GoTo Error_Handler
    

Dim sCost As String
Dim rsQuery As DAO.Recordset
Dim dbs As DAO.Database
Dim excelApp As Object
Dim rs As DAO.Recordset
Dim sFilePath As String
Dim sDepartment As String
Dim sControllable_Tab As String
Dim sExhibit_2_Tab As String
Dim sCost_Center As String
Dim sSeparator As String


'This RS is departments who are a stakeholder in an Exhibit 2 line
Set rs = CurrentDb.OpenRecordset("SELECT DISTINCT TBL_CHART.EXHIBIT_2_COST FROM TBL_CHART WHERE TBL_CHART.EXHIBIT_2_COST Is Not Null")


'Set Variables
sFilePath = "Y:\Budget process information\BUDGET DEPARTMENTS\"
sSubFolder = "\MONTHLY EXPENSE REPORTS\"
sControllable_Tab = "DETAIL_EXPENSE"
sExhibit_2_Tab = "EXHIBIT_2_DETAIL"
sSeparator = "\"


'Check to see if the recordset actually contains rows
'Do until there are no more records in the RS
If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst
    Do Until rs.EOF = True


sDepartment = DLookup("DEPARTMENT", "qryDepartment", "COST_CENTER =" & rs.Fields("EXHIBIT_2_COST"))
sCost_Center = rs.Fields("EXHIBIT_2_COST")



'##############################################################################################################


                
'Specify the query to be exported
    Set dbs = CurrentDb
    Set rsQuery = dbs.OpenRecordset("SELECT * FROM qryLedger_Detail_2019 WHERE COST_CENTER = " & sCost_Center)

'Open an instance of Excel
    On Error Resume Next
        Set excelApp = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Set excelApp = CreateObject("Excel.Application")
    End If

'Change True to False if you do not want the workbook to be
'Visible when the code is running
    excelApp.Visible = False

'Open the target workbook
    Set targetWorkbook = excelApp.workbooks.Open(sFilePath & sDepartment & sSubFolder & sDepartment & "_YTD_DETAIL")

'Copy data to the specified sheet and range
    targetWorkbook.Worksheets(sControllable_Tab).Range("A2").CopyFromRecordset rsQuery




'##############################################################################################################
'This script will loop through the rs correctly
Debug.Print sFilePath & sDepartment & sSubFolder & sDepartment & "_YTD_DETAIL"


'Close the EXCEL file while saving the file, and clean up the EXCEL objects
    Set excelApp = Nothing
    targetWorkbook.Close True
    Set targetWorkbook = Nothing
    rs.MoveNext
    
    Loop


Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."


rs.Close 'Close the recordset
Set rs = Nothing 'Clean up



'Error_Handler_Exit:
'    Exit Sub
'
'Error_Handler:
'    Select Case Err.Number
'        Case 2302
'            MsgBox "There is currently a file open with the name: " & vbCrLf & _
'                     sFilename & vbCrLf & _
'                    "Please close or rename open file! " _
'                    , vbOKOnly + vbExclamation, "DUPLICATE NAME WARNING"
'            Resume Error_Handler_Exit
'        Case Else
'            MsgBox "Error No. " & Err.Number & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
'            Err.Clear
'            Resume Error_Handler_Exit
'    End Select
    
End Sub
[\code]
 

theDBguy

I’m here to help
Staff member
Local time
Today, 06:37
Joined
Oct 29, 2018
Messages
21,357
Hi. So, what happens when you use that code? Do you get an error message? If so, what does it say and which line is causing it?
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
Sorry, I should have wrote all of that. i do not get an error message, it just hangs.
The code breaks if I open the file I am trying to write to.
It probably should not take that long, as for testing purposes I have the second recordset filtered down to return 2 rows.

I should say that I know the first recordset works correctly as I had a message box display all of the "TBL_CHART.EXHIBIT_2_COST" of which there are 10.
 

Micron

AWF VIP
Local time
Today, 09:37
Joined
Oct 20, 2018
Messages
3,476
Step through the code is usually the standard answer IMHO and see what happens. I don't see anything that's causing an endless loop (which sometimes is the reason). Maybe it's working but due to network traffic, it takes longer than you think it should. I don't see where the second recordset would come in to play unless the copyfromrecordset method is what's causing the delay.

FWIW, when testing automation code I often check task manager to ensure an instance of the file is not left hanging.
 

bastanu

AWF VIP
Local time
Today, 06:37
Joined
Apr 13, 2010
Messages
1,401
This line doesn't look right, not a valid Excel file name:
Code:
'Open the target workbook
    Set targetWorkbook = excelApp.workbooks.Open(sFilePath & sDepartment & sSubFolder & sDepartment & "_YTD_DETAIL")
Cheers,
Vlad
 

Micron

AWF VIP
Local time
Today, 09:37
Joined
Oct 20, 2018
Messages
3,476
This line doesn't look right, not a valid Excel file name:
If the lookup returns "dept" as department, it becomes
Y:\Budget process information\BUDGET DEPARTMENTS\dept\MONTHLY EXPENSE REPORTS\dept_YTD_DETAIL
which looks like there's no file extension. Don't see why that wouldn't cause an error.
 

bastanu

AWF VIP
Local time
Today, 06:37
Joined
Apr 13, 2010
Messages
1,401
It probably does but the previous error handling line is On error resume next (and the entire error handling code is commented out).
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
If the lookup returns "dept" as department, it becomes
Y:\Budget process information\BUDGET DEPARTMENTS\dept\MONTHLY EXPENSE REPORTS\dept_YTD_DETAIL
which looks like there's no file extension. Don't see why that wouldn't cause an error.

"no file extension" Excellent Observation. After I added the extension the data exported correctly!
In addition I commented out the error handling and (so far) not errors.

THANK YOU!
And thank you to everyone who commented.


Here is my final code:

Code:
Private Sub Command47_Click()

'BOF checks if current record position is before the first record
'EOF checks if current record position is after the last record
'If BOF and EOF both return TRUE, then the Table has no record
'rs.MoveFirst ‘makes the first record the current record, in case current record is not the first record

'Error handling
    On Error GoTo Error_Handler
    

Dim sCost As String
Dim rsQuery As DAO.Recordset
Dim dbs As DAO.Database
Dim excelApp As Object
Dim rs As DAO.Recordset
Dim sFilePath As String
Dim sDepartment As String
Dim sControllable_Tab As String
Dim sExhibit_2_Tab As String
Dim sCost_Center As String
Dim sSeparator As String
Dim sExtension As String

'This RS is departments who are a stakeholder in an Exhibit 2 line
Set rs = CurrentDb.OpenRecordset("SELECT DISTINCT TBL_CHART.EXHIBIT_2_COST FROM TBL_CHART WHERE TBL_CHART.EXHIBIT_2_COST Is Not Null")


'Set Variables
sFilePath = "Y:\Budget process information\BUDGET DEPARTMENTS\"
sSubFolder = "\MONTHLY EXPENSE REPORTS\"
sControllable_Tab = "DETAIL_EXPENSE"
sExhibit_2_Tab = "EXHIBIT_2_DETAIL"
sSeparator = "\"
sExtension = ".xlsm"

'Check to see if the recordset actually contains rows
'Do until there are no more records in the RS
If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst
    Do Until rs.EOF = True


sDepartment = DLookup("DEPARTMENT", "qryDepartment", "COST_CENTER =" & rs.Fields("EXHIBIT_2_COST"))
sCost_Center = rs.Fields("EXHIBIT_2_COST")



'##############################################################################################################


                
'Specify the query to be exported
    Set dbs = CurrentDb
    Set rsQuery = dbs.OpenRecordset("SELECT * FROM qryLedger_Detail_2019 WHERE COST_CENTER = " & sCost_Center)

'Open an instance of Excel
    On Error Resume Next
        Set excelApp = GetObject(, "Excel.Application")

    If Err.Number <> 0 Then
        Set excelApp = CreateObject("Excel.Application")
    End If

'Change True to False if you do not want the workbook to be
'Visible when the code is running
    excelApp.Visible = False

'Open the target workbook
    Set targetWorkbook = excelApp.workbooks.Open(sFilePath & sDepartment & sSubFolder & sDepartment & "_YTD_DETAIL" & sExtension)

'Copy data to the specified sheet and range
    targetWorkbook.Worksheets(sControllable_Tab).Range("A2").CopyFromRecordset rsQuery




'##############################################################################################################
'This script will loop through the rs correctly
'Debug.Print rs.Fields("EXHIBIT_2_COST") & " - " & sDepartment
'Debug.Print sCost_Center & sFilePath & sDepartment & sSubFolder
Debug.Print sFilePath & sDepartment & sSubFolder & sDepartment & "_YTD_DETAIL" & sExtension


'Close the EXCEL file while saving the file, and clean up the EXCEL objects
    Set excelApp = Nothing
    targetWorkbook.Close True
    Set targetWorkbook = Nothing
    rs.MoveNext
    
    Loop


Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."


rs.Close 'Close the recordset
Set rs = Nothing 'Clean up



Error_Handler_Exit:
    Exit Sub

Error_Handler:
    Select Case Err.Number
        Case 2302
            MsgBox "There is currently a file open with the name: " & vbCrLf & _
                     sFilename & vbCrLf & _
                    "Please close or rename open file! " _
                    , vbOKOnly + vbExclamation, "DUPLICATE NAME WARNING"
            Resume Error_Handler_Exit
        Case Else
            MsgBox "Error No. " & Err.Number & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
            Err.Clear
            Resume Error_Handler_Exit
    End Select
    
End Sub
 

Micron

AWF VIP
Local time
Today, 09:37
Joined
Oct 20, 2018
Messages
3,476
Glad you got it solved. I didn't dissect your code but some things jump out.
- If you're going to declare object/variables, why not use them everywhere? See CurrentDb.
- Some things don't really need variables as they refer to things that can be short concatenations and are only used once anyway, like file extension and \
- it's customary to Resume Next when doing something like getting vs creating an object instance. You have eliminated that but shouldn't. You'd switch from Resume Next to GoTo.
- if you enter the error handler then go to your resume point, it's likely that your cleanup never happens (closing rs, setting db to Nothing, dealing with Excel objects, etc.)
There may be more suggestions from others but as I said, I didn't study everything as if I was grading this or something.
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
Glad you got it solved. I didn't dissect your code but some things jump out.
- If you're going to declare object/variables, why not use them everywhere? See CurrentDb.
- Some things don't really need variables as they refer to things that can be short concatenations and are only used once anyway, like file extension and \
- it's customary to Resume Next when doing something like getting vs creating an object instance. You have eliminated that but shouldn't. You'd switch from Resume Next to GoTo.
- if you enter the error handler then go to your resume point, it's likely that your cleanup never happens (closing rs, setting db to Nothing, dealing with Excel objects, etc.)
There may be more suggestions from others but as I said, I didn't study everything as if I was grading this or something.

All valid points.
I have eliminated the unnecessary variables. You are correct, these things are small enough to just concat.
I have added the cleanup (closing rs, setting db to Nothing, dealing with Excel objects, etc.) to the line below the error resume point:
Code:
Error_Handler_Exit:

'Close the EXCEL file while saving the file, and clean up the EXCEL objects
    Set excelApp = Nothing
    targetWorkbook.Close True
    Set targetWorkbook = Nothing
    rs.MoveNext    
    Exit Sub

Error_Handler:
    Select Case Err.Number
        Case 2302
            MsgBox "There is currently a file open with the name: " & vbCrLf & _
                     sFilename & vbCrLf & _
                    "Please close or rename open file! " _
                    , vbOKOnly + vbExclamation, "DUPLICATE NAME WARNING"
            Resume Error_Handler_Exit
        Case Else
            MsgBox "Error No. " & Err.Number & vbCrLf & "Description: " & Err.DESCRIPTION, vbExclamation, "Database Error"
            Err.Clear
            Resume Error_Handler_Exit
    End Select

I can use a little more guidance on tip 1 and 3.
 

Micron

AWF VIP
Local time
Today, 09:37
Joined
Oct 20, 2018
Messages
3,476
#1- set dbs at the beginning (under Dim statements) Set rs = CurrentDb
and use Set rs = dbs.OpenRecordset instead of Set rs = CurrentDb.OpenRecordset
#3- you want error handling to cover cases where you're trying to Get an object that doesn't exist but also any other case. Rather than flipping back and forth between GoTo, Resume Next and back to GoTo I would use GoTo and and handle the error raised by trying to get an object that doesn't exist by Resuming Next in the error handler for that specific error number (in a Select Case block).
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
#1- set dbs at the beginning (under Dim statements) Set rs = CurrentDb
and use Set rs = dbs.OpenRecordset instead of Set rs = CurrentDb.OpenRecordset
#3- you want error handling to cover cases where you're trying to Get an object that doesn't exist but also any other case. Rather than flipping back and forth between GoTo, Resume Next and back to GoTo I would use GoTo and and handle the error raised by trying to get an object that doesn't exist by Resuming Next in the error handler for that specific error number (in a Select Case block).

1 - When I make this change, I get a run time 13 error on the "Set rs = CurrentDb" line?
3 - How can I find out the error number that this will raise? In other words how can I force it to try to get an object that doesn't exist?

This is all very helpful, and I appreciate you keeping in touch.
 

MrHans

Registered User
Local time
Today, 14:37
Joined
Jul 27, 2015
Messages
147
With regards to point 1,it's a typo from Micron. It should be

Dim dbs as DAO.Database
Dim rs as dao.recordset

Set dbs = CurrentDb
Set rs = db.openrecordset(...)
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
With regards to point 1,it's a typo from Micron. It should be

Dim dbs as DAO.Database
Dim rs as dao.recordset

Set dbs = CurrentDb
Set rs = db.openrecordset(...)

That was it
 

Micron

AWF VIP
Local time
Today, 09:37
Joined
Oct 20, 2018
Messages
3,476
Sorry about that. Not sure if it was a copy/paste thing or what.
What I DO know is that over the last few days, while I'm typing, weird stuff happens - such as a whole line gets highlighted then one more keystroke replaces everything I typed beforehand. Even as I type this reply, my cursor jumped up to the top and starting inserting what I was typing. It's REALLY P!$$!ng me off. I'm going to Google how to disable the touch pad to see if that helps. Started one day after the last Windows downgrade.
 

jeran042

Registered User.
Local time
Today, 06:37
Joined
Jun 26, 2017
Messages
127
Sorry about that. Not sure if it was a copy/paste thing or what.
What I DO know is that over the last few days, while I'm typing, weird stuff happens - such as a whole line gets highlighted then one more keystroke replaces everything I typed beforehand. Even as I type this reply, my cursor jumped up to the top and starting inserting what I was typing. It's REALLY P!$$!ng me off. I'm going to Google how to disable the touch pad to see if that helps. Started one day after the last Windows downgrade.

That does sound INCREDIBLY aggravating!!
Its good to have curve balls, It forces me to troubleshoot.
I think I might have to post another question. I'm in the second leg of this code. Outputting 2 different recordsets to two different tabs in the same workbook.
 

Users who are viewing this thread

Top Bottom