Solved

setting recordset - Movefirst - maybe in wrong place w/i Code

Posted on 2010-11-28
3
630 Views
Last Modified: 2012-05-10
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
'---------------------------------------------------------------------------------------
' 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

Open in new window

0
Comment
Question by:Karen Schaefer
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
3 Comments
 
LVL 65

Accepted Solution

by:
rockiroads earned 500 total points
ID: 34226216
My recommendation is to check records exists before navigating the recordset

eg

this bit of code here

        Set rs1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
        rs1.MoveFirst

Perhaps you should check rs1.eof property is not true before attempting the movefirst

        Set rs1 = CurrentDb.OpenRecordset(strSQL1, dbOpenSnapshot)
        if rs1.eof = true then
            msgbox "Nothing here"
        else
            'rest of your code including
            rs1.MoveFirst



and same applies earlier on in your code

    Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
    If rs.recordCount = 0 Then

do not use recordcount to check no records, use eof instead


0
 
LVL 34

Expert Comment

by:Norie
ID: 34233017
Do you actually need to use MoveFirst anywhere?

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.:)
conn.ConnectionString = strConn
    
    conn.Open

    sql = "SELECT * FROM customers;"
    
    Set rs = New ADODB.Recordset
    
    rs.Open sql, conn

    Set rng = Worksheets("Sheet1").Range("A1")
    
    For Each fld In rs.Fields
        rng = fld.Name
        Set rng = rng.Offset(, 1)
    Next fld
    
    Set rng = Worksheets("Sheet1").Range("A2")
    
    While Not rs.EOF
        For Each fld In rs.Fields
            rng.Value = fld.Value
            Set rng = rng.Offset(, 1)
        Next fld
        rs.MoveNext
        Set rng = rng.Offset(1, 1 - rng.Column)
        
    Wend

Open in new window

0
 

Author Closing Comment

by:Karen Schaefer
ID: 34233316
Thanks, I just reorder the code a little bit and did as you suggested and it works great.

K
0

Featured Post

Three Reasons Why Backup is Strategic

Backup is strategic to your business because your data is strategic to your business. Without backup, your business will fail. This white paper explains why it is vital for you to design and immediately execute a backup strategy to protect 100 percent of your data.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
Traditionally, the method to display pictures in Access forms and reports is to first download them from URLs to a folder, record the path in a table and then let the form or report pull the pictures from that folder. But why not let Windows retr…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
With Secure Portal Encryption, the recipient is sent a link to their email address directing them to the email laundry delivery page. From there, the recipient will be required to enter a user name and password to enter the page. Once the recipient …

623 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question