Results 1 to 4 of 4
  1. #1
    4 Star Lounger
    Join Date
    Oct 2002
    Location
    Sayre, Pennsylvania, USA
    Posts
    504
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Export query criteria to Excel Wkbooks (2000)

    Hi,
    I have the following code that works great. It exports data from a query and based on criteria it creates 3 separate sheets per file. (oem, bearings, vendor). Now I'm being asked to change this to 3 separate files instead of sheets. How can I modify this code? Also I'd like the file name to be something like 04FMAN-Bearings-DPL.xls. 04FMAN is the strMaterialJON, bearings is the criteria, and DPL is just text I'd like added. Thanks, Deb

    Option Compare Database

    Private Sub cmdExportExcel_Click()

    DoCmd.Hourglass True

    Dim myID As Long
    Dim theRecSource As Long

    Dim xlApp As Object
    Dim myWorkbook As Object
    Dim mySheet As Object

    Dim theFilePath As String
    Dim theTemplateFile As String
    Dim theDestFile As String

    theFilePath = "M:Machine PartsExcel DPL Files"
    theTemplateFile = theFilePath & "QuoteForm.xls"
    SetAttrib theTemplateFile, vbReadOnly
    theDestFile = theFilePath & Me!strMaterialJON & "-DPL.xls"

    myID = [Forms]![frmDPLEntry]![cboMachJON]

    Set xlApp = CreateObject("Excel.Application")
    Set mySheet = xlApp.workbooks.Open(theTemplateFile).sheets(1)

    mySheet.cells(3, 2).Value = Me!strMaterialJON
    mySheet.cells(4, 2).Value = Me!strMachID
    mySheet.cells(5, 2).Value = Me!strMachineSerialNo
    mySheet.cells(4, 7).Value = Me!calcMachNameModel
    mySheet.cells(5, 7).Formula = "=DateValue(" & Chr(34) & Me!dtm4130CompletionDate & Chr(34) & ")"
    mySheet.cells(5, 7).NumberFormat = "[$-409]d-mmm-yy;@"
    mySheet.cells(11, 2).Value = Me!sfrmPartsSubform!cboRecSource.Column(1)

    Dim VendorSheet As Object
    Dim OEMSheet As Object
    Dim BearingsSheet As Object

    mySheet.Copy after:=mySheet
    mySheet.Copy after:=mySheet

    Set VendorSheet = xlApp.workbooks(1).sheets(1)
    VendorSheet.Name = "Vendor"
    Set OEMSheet = xlApp.workbooks(1).sheets(2)
    OEMSheet.Name = "OEM"
    Set BearingsSheet = xlApp.workbooks(1).sheets(3)
    BearingsSheet.Name = "Bearings"


    PopulateParts myID, 4, "Vendor", VendorSheet
    PopulateParts myID, 8, "OEM", OEMSheet
    PopulateParts myID, 9, "Bearings", BearingsSheet

    mySheet.Application.activeworkbook.SaveAs Filename:=theDestFile
    mySheet.Application.activeworkbook.Close
    xlApp.Quit

    Set mySheet = Nothing
    Set xlApp = Nothing

    DoCmd.Hourglass False

    MsgBox "The Excel export is finished. The file is located at " & theFilePath

    End Sub

    Private Sub PopulateParts(theMachineID As Long, theRecSourceID As Long, _
    theRecSourceName As String, theWorksheet As Object)

    Dim DB As DAO.Database
    Dim Rs As DAO.Recordset
    Dim i As Integer
    Dim theColumn As Integer
    Dim theRow As Integer
    Dim RsSql As String
    Dim CurrentField As Variant

    theWorksheet.cells(11, 2).Value = theRecSourceName

    Set DB = DBEngine.Workspaces(0).Databases(0)

    RsSql = "SELECT * FROM [qryQuoteForm] WHERE [lngMachineID] =" & theMachineID & _
    " AND lngRecSourceID = " & theRecSourceID

    Set Rs = DB.OpenRecordset(RsSql, dbOpenDynaset)

    theRow = 13

    Do Until Rs.EOF
    For i = 0 To Rs.Fields.Count - 3 'the 3 is used to get rid of the machineid field
    'from the query because index counting starts at 0
    'the 3 is minus 1 minus 1 to take away the last two field
    'and make the index count the number of fields correct
    'original code was 1 but showed machineid in result
    CurrentField = Rs(i) 'CurrentValue = Rs.Fields(i).Value
    theWorksheet.cells(theRow, i + 1).Value = CurrentField
    Next i
    Rs.MoveNext
    theRow = theRow + 1
    Loop

    End Sub

  2. #2
    Lounger
    Join Date
    Jan 2004
    Location
    Derry, Derry, Ireland, Northern
    Posts
    35
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Export query criteria to Excel Wkbooks (2000)

    Hi Deb,

    If I read the code correctly, the line "PopulateParts myID, 9, "Bearings", BearingsSheet" indicates the point where the three sheets in the new workbook have been populated with the data you wish them to contain.

    it is at this point that you can copy each sheet to a new workbook. For example:

    VendorSheet.select
    VendorSheet.copy

    will create a copy of the "Vendor" sheet in a new workbook

    If you follow it with the lines:

    xlapp.activeworkbook.SaveAs Filename:= theFilePath & Me!strMaterialJON & "-" & VendorSheet.Name & "-DPL.xls"
    xlapp.activeworkbook.Close

    This will save the new workbook in the specified directory with the required name, and close the file.

    For the other sheets, repeat the lines and substitute OEMSheet and BearingSheet for VendorSheet.

    The line "mySheet.Application.activeworkbook.SaveAs Filename:=theDestFile" may now be redundant - it contains the 3 sheets that have now been copied to individual files and saved.

    Best to make a backup of your working code before embarking on this though [img]/forums/images/smilies/smile.gif[/img])

    HTH

  3. #3
    4 Star Lounger
    Join Date
    Oct 2002
    Location
    Sayre, Pennsylvania, USA
    Posts
    504
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Export query criteria to Excel Wkbooks (2000)

    Ok, I updated my code and it worked once and now I get this error. Run-time error '1004': Cannot rename a sheet to the same name as another sheet, a referenced object library or a workbook referenced by Visual Basic. It then highlights the following code line: OEMSheet.Name = "OEM"

    Here's my new code:
    Option Compare Database

    Private Sub cmdExportExcel_Click()

    DoCmd.Hourglass True

    Dim myID As Long
    Dim theRecSource As Long

    Dim xlApp As Object
    Dim myWorkbook As Object
    Dim mySheet As Object

    Dim theFilePath As String
    Dim theTemplateFile As String
    Dim theDestFile As String

    theFilePath = "M:Machine PartsExcel DPL Files"
    theTemplateFile = theFilePath & "QuoteForm.xls"
    theDestFile = theFilePath & Me!strMaterialJON & "-DPL.xls"

    myID = [Forms]![frmDPLEntry]![cboMachJON]

    Set xlApp = CreateObject("Excel.Application")
    Set mySheet = xlApp.workbooks.Open(theTemplateFile).sheets(1)

    mySheet.cells(3, 2).Value = Me!strMaterialJON
    mySheet.cells(4, 2).Value = Me!strMachID
    mySheet.cells(5, 2).Value = Me!strMachineSerialNo
    mySheet.cells(4, 7).Value = Me!calcMachNameModel
    mySheet.cells(5, 7).Formula = "=DateValue(" & Chr(34) & Me!dtm4130CompletionDate & Chr(34) & ")"
    mySheet.cells(5, 7).NumberFormat = "[$-409]d-mmm-yy;@"
    mySheet.cells(11, 2).Value = Me!sfrmPartsSubform!cboRecSource.Column(1)

    Dim VendorSheet As Object
    Dim OEMSheet As Object
    Dim BearingsSheet As Object

    mySheet.copy after:=mySheet
    mySheet.copy after:=mySheet

    Set VendorSheet = xlApp.workbooks(1).sheets(1)
    VendorSheet.Name = "Vendor"
    Set OEMSheet = xlApp.workbooks(1).sheets(2)
    OEMSheet.Name = "OEM"
    Set BearingsSheet = xlApp.workbooks(1).sheets(3)
    BearingsSheet.Name = "Bearings"


    PopulateParts myID, 4, "Vendor", VendorSheet
    PopulateParts myID, 8, "OEM", OEMSheet
    PopulateParts myID, 9, "Bearings", BearingsSheet

    VendorSheet.select
    VendorSheet.copy
    xlApp.activeworkbook.SaveAs Filename:=theFilePath & Me!strMaterialJON & _
    "-" & VendorSheet.Name & "-DPL.xls"
    xlApp.activeworkbook.Close

    OEMSheet.select
    OEMSheet.copy
    xlApp.activeworkbook.SaveAs Filename:=theFilePath & Me!strMaterialJON & _
    "-" & OEMSheet.Name & "-DPL.xls"
    xlApp.activeworkbook.Close

    BearingsSheet.select
    BearingsSheet.copy
    xlApp.activeworkbook.SaveAs Filename:=theFilePath & Me!strMaterialJON & _
    "-" & BearingsSheet.Name & "-DPL.xls"
    xlApp.activeworkbook.Close

    mySheet.Application.activeworkbook.SaveAs Filename:=theDestFile
    mySheet.Application.activeworkbook.Close
    xlApp.Quit

    Set mySheet = Nothing
    Set xlApp = Nothing

    DoCmd.Hourglass False

    MsgBox "The Excel export is finished. The files are located at " & theFilePath

    End Sub

    Private Sub PopulateParts(theMachineID As Long, theRecSourceID As Long, _
    theRecSourceName As String, theWorksheet As Object)

    Dim DB As DAO.Database
    Dim Rs As DAO.Recordset
    Dim i As Integer
    Dim theColumn As Integer
    Dim theRow As Integer
    Dim RsSql As String
    Dim CurrentField As Variant

    theWorksheet.cells(11, 2).Value = theRecSourceName

    Set DB = DBEngine.Workspaces(0).Databases(0)

    RsSql = "SELECT * FROM [qryQuoteForm] WHERE [lngMachineID] =" & theMachineID & _
    " AND lngRecSourceID = " & theRecSourceID

    Set Rs = DB.OpenRecordset(RsSql, dbOpenDynaset)

    theRow = 13

    Do Until Rs.EOF
    For i = 0 To Rs.Fields.Count - 3 'the 3 is used to get rid of the machineid field
    'from the query because index counting starts at 0
    'the 3 is minus 1 minus 1 to take away the last two field
    'and make the index count the number of fields correct
    'original code was 1 but showed machineid in result
    CurrentField = Rs(i) 'CurrentValue = Rs.Fields(i).Value
    theWorksheet.cells(theRow, i + 1).Value = CurrentField
    Next i
    Rs.MoveNext
    theRow = theRow + 1
    Loop


    End Sub

  4. #4
    4 Star Lounger
    Join Date
    Oct 2002
    Location
    Sayre, Pennsylvania, USA
    Posts
    504
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Export query criteria to Excel Wkbooks (2000)

    Thanks for your earlier reply. I found the answer to my last post. I had to rename my sheet names in the QuoteForm file. But everything is now working GREAT!

    Thank You,
    Deb

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •