Karen Schaefer
asked on
setting recordset - Movefirst - maybe in wrong place w/i Code
The code below is creating an export and new Excel workbook based on data within Access database and an Excel Template. The code compiles the data creates the column headings and inputs the data into the Excel Workbook on the fly.
The code work correctly - creating the workbook, and compiling the Access data correctly, however, When the code comes to the rs.movefirst portion of the code that is suppose to input the data for Column headings w/i the Excel workbook, it moves to the error handling and gets stuck in a loop. See '<<<<<<<<<<<<<<<<<<<<<<<< with in the code for problem error.
What am I missing?
Thanks,
Karen
The code work correctly - creating the workbook, and compiling the Access data correctly, however, When the code comes to the rs.movefirst portion of the code that is suppose to input the data for Column headings w/i the Excel workbook, it moves to the error handling and gets stuck in a loop. See '<<<<<<<<<<<<<<<<<<<<<<<< with in the code for problem error.
What am I missing?
Thanks,
Karen
'---------------------------------------------------------------------------------------
' Procedure : cmdExportToExcel_Click
' DateTime : 10/15/2010 13:12
' Author : Karen F. Schaefer, DBA
' Purpose : Export Training Data to Excel Template and populates the appropriate worksheets accordingly.
'---------------------------------------------------------------------------------------
'
Private Sub cmdExportToExcel_Click()
On Error GoTo cmdExportToExcel_Click_Error
On Error GoTo ProcError
'For Late Binding
' Dim xlApp As Object
'For Early Binding
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet, xlWs1 As Excel.Worksheet
Dim rs As DAO.Recordset
Dim rs1 As DAO.Recordset, rs2 As DAO.Recordset, rs3 As DAO.Recordset
Dim strSQL As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim strSQL3 As String
Dim strFolder As String
Dim strFileName As String
Dim I As Long, intRecordCount As Long
Dim blnSuccess As Boolean
Dim gWkSht As String, gWkSht1 As String
Dim gBEMS As String
StatusMsg Me, ""
StatusMsg Me, "Please Wait while the data is being refreshed.", vbBlue
Me.txtStatusMsg.Requery
cmdUpdateData_Click
StatusMsg Me, "Employee Training data has been updated.", vbBlue
Me.txtStatusMsg.Requery
strFolder = GetUsersDesktopFolder
strFileName = strFolder & "2010 FTI-ME Ent-DP.xls"
'Determines the column headings for the Training Matrix spreadsheet(s)
strSQL = "SELECT Mid([Ilp Learning Title],1,InStrRev([Ilp Learning Title],'(')-1) AS CourseTitle," & _
" TL_CourseList.[Ilp Learning Cd] AS CourseNumber, TL_CourseList.[Delv Mthd Tot Hrs] AS Duration," & _
" TL_CourseClassification.ClassType, TL_CourseList.StandardRequiredDt" & _
" FROM TL_CourseClassification INNER JOIN TL_CourseList ON" & _
" TL_CourseClassification.ClassificationRecID = TL_CourseList.ClassificationRecID" & _
" WHERE (((TL_CourseList.OnXLS)=-1))" & _
" GROUP BY Mid([Ilp Learning Title],1,InStrRev([Ilp Learning Title],'(')-1), TL_CourseList.[Ilp Learning Cd]," & _
" TL_CourseList.[Delv Mthd Tot Hrs], TL_CourseClassification.ClassType, TL_CourseList.StandardRequiredDt" & _
" ORDER BY TL_CourseList.StandardRequiredDt, TL_CourseList.[Ilp Learning Cd]"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
If rs.RecordCount = 0 Then
MsgBox "There Are No Records to Export for the Courses Selected.", vbInformation, "No Data To Export..."
GoTo ExitProc
Else
rs.MoveLast: rs.MoveFirst 'Required to get an accurate count of records.
intRecordCount = rs.RecordCount
End If
If Dir(strFileName) <> "" Then
Kill (strFileName)
End If
'Sets name of Excel worksheet within the Workbook based on above mentioned Template -
'to be updated based on Unit Chief Name selected form listbox
strSQL1 = "SELECT UCBEMS, WkshtName, wkshtname1 FROM qryUnitChief WHERE UnitChiefID In (" & MyString & ")"
If rs.RecordCount = 0 Then
Call _
MsgBox("Please make a selection from the list, Click Update and then Click Export to Excel upon completion of the processing of the Update Data.", _
vbCritical, "No Data Found")
Else
Set rs1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add(CurrentProject.path & "\2010 FTI-ME Ent-DP.xlt")
xlApp.Visible = True
rs1.MoveFirst
Do Until rs1.EOF
gWkSht = rs1.Fields("WkshtName").value
gBEMS = rs1.Fields("UCBEMS").value
gWkSht1 = rs1.Fields("WkshtName1").value
Set xlWs = xlWb.Worksheets(gWkSht)
Set xlWs1 = xlWb.Worksheets(gWkSht1)
'Copy course name and course number data, starting at cell F11 = Row 11, Column 6
I = 6
With xlWs
StatusMsg Me, "Please Wait while the Course Titles are being updated for " & gWkSht1 & " .", vbBlue
Me.txtStatusMsg.Requery
rs.MoveFirst '<<<<<<<<<<<<<<<<<<<<<<<<
Do Until rs.EOF
.Cells(6, 3).value = Date 'Date Report Ran
.Cells(6, I).value = rs!StandardRequiredDt 'Course Required by Date
.Cells(7, I).value = rs!Duration 'Course duration
.Cells(8, I).value = rs!ClassType 'Source of Course
.Cells(9, I).value = Trim(rs!CourseTitle) 'Course Title
.Cells(10, I).value = rs!CourseNumber 'Course ID
I = I + 1
rs.MoveNext
Loop
'Copy detail data, starting at cell "A11"(eleven)
strSQL2 = "SELECT * FROM zTempData" & _
" WHERE UCBEMS IN(" & Chr(34) & gBEMS & Chr(34) & ")" & _
" ORDER BY EmployeeName"
Set rs2 = CurrentDb.OpenRecordset(strSQL2, dbOpenSnapshot)
.Range("A11").CopyFromRecordset rs2
End With
blnSuccess = True
StatusMsg Me, "Please Wait while the system formats " & gWkSht & ".", vbBlue
Me.txtStatusMsg.Requery
FormatWS xlWs
StatusMsg Me, "Please Wait while the data for " & gWkSht1 & " is being updated.", vbRed
Me.txtStatusMsg.Requery
With xlWs1
'Copy Summary data, starting at cell "A6"
strSQL3 = "SELECT qryEmpInfo.Mgr_OrgNo," & _
" Sum(IIf([CompletionDt]<=[DateRequired],1,0)) AS OnTime, Sum(IIf([CompletionDt]>[DateRequired],1,0)) AS Late," & _
" Sum(IIf([DateRequired]>Date(),1,0)) AS Avail, Sum(IIf([DateRequired]<Date(),1,0)) AS Del," & _
" Count(TD_EmpReqLearning.CourseRecID) AS TotalCourseCt," & _
" IIf(Count([CourseRecID])=0,0,Sum(IIf([CompletionDt]<=[DateRequired],1,0))/Count([CourseRecID])) AS [%CompleteOnTime]," & _
" IIf(Count([CourseRecID])=0,0,Sum(IIf([CompletionDt]>[DateRequired],1,0))/Count([CourseRecID])) AS [%CompleteLate]," & _
" IIf(Count([CourseRecID])=0,0,Sum(IIf([DateRequired]<Date(),1,0))/Count([CourseRecID])) AS [%CompleteDel]" & _
" FROM TD_EmpReqLearning RIGHT JOIN qryEmpInfo ON TD_EmpReqLearning.BEMS = qryEmpInfo.TA_Empl.BEMS" & _
" WHERE (qryEmpInfo.UnitChiefID =" & Chr(34) & gBEMS & Chr(34) & ")" & _
" GROUP BY qryEmpInfo.UnitChiefID, qryEmpInfo.UnitChief, qryEmpInfo.Mgr_OrgNo" & _
" ORDER BY qryEmpInfo.UnitChief"
Debug.Print strSQL3
'Copy Summary data per Manager per Unit Chief
Set rs3 = CurrentDb.OpenRecordset(strSQL3, dbOpenSnapshot)
.Range("A6").CopyFromRecordset rs3
End With
rs1.MoveNext
Loop
If blnSuccess = True Then
StatusMsg Me, Mid(strFileName, Len(strFolder) + 1) & " report has been saved to your Desktop folder.", vbBlue
Me.txtStatusMsg.Requery
End If
End If
' optional but perhaps useful to monitor progress
xlWb.SaveAs strFileName
ExitProc:
'Cleanup code
rs1.Close: Set rs1 = Nothing
rs2.Close: Set rs2 = Nothing
rs3.Close: Set rs3 = Nothing
Exit Sub
ProcError:
' error handling code
Resume ExitProc
Resume
On Error GoTo 0
Exit Sub
cmdExportToExcel_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdExportToExcel_Click of VBA Document Form_frmExportToExcel"
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thanks, I just reorder the code a little bit and did as you suggested and it works great.
K
K
I've only ever seen it used when data is being updated.
You can use code like this to populate a worksheet from a recordset.
Of course this is a straightforward transfer to rows with a column for each field.
It also doesn't include code for putting the headers on the worksheet but that could be done easily.
One way would be to loop through the fields collection of the recordset, which I've added.:)
Open in new window