Solved

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

Posted on 2010-11-28
3
615 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
3 Comments
 
LVL 65

Accepted Solution

by:
rockiroads earned 500 total points
Comment Utility
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 33

Expert Comment

by:Norie
Comment Utility
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
Comment Utility
Thanks, I just reorder the code a little bit and did as you suggested and it works great.

K
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
Experts-Exchange is a great place to come for help with solutions for your database issues, and many problems are resolved within minutes of being posted.  Others take a little more time and effort and often providing a sample database is very helpf…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Basics of query design. Shows you how to construct a simple query by adding tables, perform joins, defining output columns, perform sorting, and apply criteria.

744 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

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now