jeran042
Registered User.
- Local time
- Today, 04:17
- 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.
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]
