Page 2 of 2 FirstFirst 12
Results 16 to 25 of 25
  1. #16
    pbaldy's Avatar
    pbaldy is online now Who is John Galt?
    Windows XP Access 2007
    Join Date
    Feb 2010
    Location
    Nevada, USA
    Posts
    22,518
    This should help debug the SQL:



    http://www.baldyweb.com/ImmediateWindow.htm

    My code was intended to be for guidance only, you'd need to add all the appropriate Dim's, etc (like for the recordsets and database, which you don't have). Presuming your name field is text, try:

    strSQL = "SELECT * FROM salesinfoforcurryrplan_crosstab WHERE saname = " & Chr(34) & rssalesinfoforcurryrplan_crosstab!SANAME & Chr(34)

    Feel free to change the names of the recordsets. Basically you have the first one that grabs the distinct names, the second one gets each person's data inside the loop of the first.
    Paul (wino moderator)
    MS Access MVP 2007-2019
    www.BaldyWeb.com

  2. #17
    ssanfu is offline Master of Nothing
    Windows 7 32bit Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    I didn't try Paul's solution (yet)
    I kinda got invested in this using VBA. It has been a while since I used Access automation to manipulate Excel.
    I spent way more hours on this than I should have, but I am not going to be defeated. (I hope)


    Note: There needs to be a reference set to "Microsoft Excel 14.0 Object Library".


    You will need/should add error handler code.
    Here is the code:
    Code:
    Option Compare Database
    Option Explicit
    
    Sub ExportSA()
        Dim d As DAO.Database
        Dim r As DAO.Recordset
        Dim sSQL As String
    
        Dim xlx As Object
        Dim xlw As Object
        Dim xls As Object
        Dim xlc As Object
    
        Dim strPathFileName As String
        Dim strRecordsetDataSource As String
        Dim lngColumn As Long
        Dim blnEXCEL As Boolean
        Dim blnHeaderRow As Boolean
        Dim sa_Array()         '<<-- array if unique sanames
        Dim rc As Integer  '<<-- record count
        Dim i As Integer    '<<-- just a counter
    
        Set d = CurrentDb()
    
        blnEXCEL = False
        ' Replace True with False if you do not want the first row of  the worksheet to be a header row (the names of the fields from the recordset)
        blnHeaderRow = True
    
        '+=+=+=+=+=   query to get the unique saNames   +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=
        sSQL = " SELECT DISTINCT sifcpct.saname"
        sSQL = sSQL & " FROM salesinfoforcurryrplan_crosstab sifcpct"
        sSQL = sSQL & " ORDER BY sifcpct.saname;"
    
        'get the unique sanames
        Set r = d.OpenRecordset(sSQL)
        If r.BOF And r.EOF Then
            MsgBox " No Records to export!     Aborting"
            Exit Sub
        Else
            r.MoveLast                '<<-- fill the recordset
            rc = r.RecordCount  ' <<-- number of unique sanames
            r.MoveFirst
    
            ' now we know the number of exements needed in the array
            ReDim sa_Array(rc)
    
            'fill array
            For i = 1 To rc
                sa_Array(i) = r.Fields("saname")
                r.MoveNext
            Next
        End If
    
        r.Close     'close recordset
        '++=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+
    
    
        ' Replace C:\Filename.xls with the actual path and filename  that will be used to save the new EXCEL file into which you will write the data
        strPathFileName = CurrentProject.Path & "\ExcelFilesToRepsForInputDataZZ_Plan_Sales.xlsx"
    
        ' Replace QueryOrTableName with the real name of the table or query whose data are to be written into the worksheet
        strRecordsetDataSource = "salesinfoforcurryrplan_crosstab"
    
        ' Establish an EXCEL application object
        On Error Resume Next
        Set xlx = GetObject(, "Excel.Application")
        If Err.Number <> 0 Then
            Set xlx = CreateObject("Excel.Application")
            blnEXCEL = True
        End If
        Err.Clear
        On Error GoTo 0
    
        ' Change True to False if you do not want the workbook to be visible when the code is running
        xlx.Visible = False
    
        ' Create a new EXCEL workbook =>    Set xlw = xlx.Workbooks.Add(strPathFileName)
        Set xlw = xlx.Workbooks.Add(xlWBATWorksheet)
    
        'Loop to create worksheet for each Rep
        For i = 1 To rc     '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
            xlw.Worksheets.Add After:=xlw.Worksheets(xlw.Worksheets.Count)
            '        MsgBox xlw.Worksheets.Count
    
            'delete "Sheet1"
            If i = 1 Then
                xlw.Worksheets("Sheet1").Delete
            End If
    
            xlw.ActiveSheet.Name = sa_Array(i)
    
            Set xls = xlw.ActiveSheet
    
            ' Replace A1 with the cell reference of the first cell into which the  headers will be written (blnHeaderRow = True),
            ' or into which the data  values will be written (blnHeaderRow = False)
            Set xlc = xls.Range("A1")    ' this is the first cell into which data go
    
            'Crosstab SQL by Sales Rep
            sSQL = "TRANSFORM Sum(SalesInfoforCurrYrPlan.SumOfIHDAR_FCAMT1) AS SumOfSumOfIHDAR_FCAMT1"
            sSQL = sSQL & " SELECT SalesInfoforCurrYrPlan.saname, SalesInfoforCurrYrPlan.plant, SalesInfoforCurrYrPlan.CSNAME, "
            sSQL = sSQL & " SalesInfoforCurrYrPlan.PLYear, Sum(SalesInfoforCurrYrPlan.SumOfIHDAR_FCAMT1) AS [Total Of SumOfIHDAR_FCAMT1]"
            sSQL = sSQL & " FROM SalesInfoforCurrYrPlan"
            sSQL = sSQL & " WHERE SalesInfoforCurrYrPlan.saname ='" & sa_Array(i) & "'"
            sSQL = sSQL & " GROUP BY SalesInfoforCurrYrPlan.saname, SalesInfoforCurrYrPlan.plant, SalesInfoforCurrYrPlan.CSNAME, SalesInfoforCurrYrPlan.PLYear"
            sSQL = sSQL & " ORDER BY SalesInfoforCurrYrPlan.saname, SalesInfoforCurrYrPlan.plant, SalesInfoforCurrYrPlan.CSNAME, SalesInfoforCurrYrPlan.PLYear"
            sSQL = sSQL & " PIVOT SalesInfoforCurrYrPlan.PLMth;"
            Set r = d.OpenRecordset(sSQL, dbOpenDynaset, dbReadOnly)
    
            If r.EOF = False And r.BOF = False Then
                r.MoveLast
                r.MoveFirst
    
                ' Write the HEADER row to worksheet
                If blnHeaderRow = True Then
                    For lngColumn = 0 To r.Fields.Count - 1
                        xlc.Offset(0, lngColumn).Value = r.Fields(lngColumn).Name
                    Next lngColumn
                    Set xlc = xlc.Offset(1, 0)
                End If
    
                ' write DATA to worksheet
                Do While r.EOF = False
                    For lngColumn = 0 To r.Fields.Count - 1
                        xlc.Offset(0, lngColumn).Value = r.Fields(lngColumn).Value
                    Next lngColumn
                    r.MoveNext
                    Set xlc = xlc.Offset(1, 0)
                Loop
            End If
        Next   '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    
    
        ' Clean up the VB objects
        r.Close
        Set r = Nothing
        d.Close
        Set d = Nothing
    
        ' Save and close the EXCEL file, and clean up the EXCEL objects
        xlw.SaveAs strPathFileName
        xlw.Close False
        Set xlw = Nothing
        If blnEXCEL = True Then
            xlx.Quit
        End If
    
        Set xlx = Nothing
        Set xlc = Nothing
        Set xls = Nothing
    
    
        MsgBox "Data have been exported.", vbOKOnly
    
    End Sub
    I can attach the dB I created if you have trouble....

    Good luck with your project..

  3. #18
    ebrommhead is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Nov 2012
    Location
    Mississauga
    Posts
    28
    Thanks for your assistance, Paul. The changes that you suggested seemed to work, however, I now have a run-time error 1004 a bit lower. Attached a work file to show the explanation.

    Here is my updated code for the entire project and as I mentioned earlier, I am somewhat out of my depth with this. Your assistance is appreciated.

    Private Sub Command43_Click()
    Dim strSQL As String
    Dim strTemplate As String
    Dim saname As String
    Dim rs As DAO.Recordset
    Dim XL As Object
    Dim db As DAO.Database
    Dim strfile As String




    Set db = CurrentDb()

    'strSQL = "SELECT DISTINCT Account FROM qryVenetianData"
    strSQL = "SELECT DISTINCT SAName FROM salesinfoforcurryrplan_crosstab"
    'Set rsVenetianData = db.OpenRecordset(strSQL, dbOpenDynaset)
    Set rssalesinfoforcurryrplan_crosstab = db.OpenRecordset(strSQL, dbOpenDynaset)
    'strTemplate = "C:\AccessAp\VenetianTeimplate.xlsx"
    strTemplate = CurrentProject.Path & "\Master.xltm"

    'Do While Not rsVenetianData.EOF
    Do While Not rssalesinfoforcurryrplan_crosstab.EOF
    'strSQL = "SELECT * "& "FROM qryVenetianData WHERE Account = " & rsVenetianData!Account
    'strSQL = "SELECT * " & "FROM salesinfoforcurryrplan_crosstab WHERE saname = " & rssalesinfoforcurryrplan_crosstab!SANAME
    strSQL = "SELECT * FROM salesinfoforcurryrplan_crosstab WHERE saname = " & Chr(34) & rssalesinfoforcurryrplan_crosstab!saname & Chr(34)


    'Set rsCurrent = db.OpenRecordset(strSQL, dbOpenDynaset)
    Set rsCurrent = db.OpenRecordset(strSQL, dbOpenDynaset)

    'strFile = "C:\AccessAp\VenetianData_" & rsVenetianData!Account & ".xlsx"
    strfile = CurrentProject.Path & "\excelfilestorepsforinputdata" & "ZZ_Plan_Sales " & rssalesinfoforcurryrplan_crosstab!saname & ".xlsx"


    FileCopy strTemplate, strfile

    Set XL = CreateObject("excel.application")
    XL.Workbooks.Open (strfile)
    Debug.Print XL.Workbooks.Open
    Set xlSheet = XL.Worksheets("sheet1")
    xlSheet.Select

    xlSheet.Range("A23").CopyFromRecordset rsCurrent

    'Copy A Range of Data
    Worksheets("Sheet1").Range("j15:q15").Copy

    'PasteSpecial Values Only
    Worksheets("Sheet1").Range("j18").PasteSpecial Paste:=xlPasteValues

    'Copy actual data
    Sheets("Sheet1").Range("e22").Copy (Sheets("Sheet1").Range("e23:e3000"))


    XL.ActiveWorkbook.Save
    XL.Quit
    Set XL = Nothing
    Set xlSheet = Nothing


    rssalesinfoforcurryrplan_crosstab.MoveNext
    Loop

    End Sub
    Attached Files Attached Files

  4. #19
    ebrommhead is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Nov 2012
    Location
    Mississauga
    Posts
    28
    Thanks for your input Steve, it is much appreciated. Your code gives me one excel workbook with one worksheet for each sales rep. However, what I need is use my Excel Macro-enabled Template to create one workbook(file) for each sale rep. The template is in the same directory as the MS Access program and is named "Master.xltm". In each file, I would copy the records starting at cell A23.

    Actually the code below works to a degree, it uses the template and copies the records to the right place and does a few other things to the records, but it has all the reps in one workbook and not in individual files. If you could help to create an individual file or workbook for each rep, it would be great.

    Current code:

    Private Sub Command41_Click()

    Dim lngColumn As Long
    Dim xlx As Object
    Dim xlw As Object, xls As Object, xlc As Object
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim strPathFileName As String, strWorksheetName As String
    Dim strRecordsetDataSource As String
    Dim blnEXCEL As Boolean, blnHeaderRow As Boolean
    Dim saname As String
    Dim tmpltfile As String


    blnEXCEL = False

    ' Replace C:\Filename.xls with the actual path and filename
    ' that will be used to save the new EXCEL file into which you
    ' will write the data
    strPathFileName = CurrentProject.Path & "\excelfilestorepsforinputdata" & "ZZ_Plan_Sales.xlsx"

    ' Replace QueryOrTableName with the real name of the table or query
    ' whose data are to be written into the worksheet
    strRecordsetDataSource = "salesinfoforcurryrplan_crosstab"

    ' Replace True with False if you do not want the first row of
    ' the worksheet to be a header row (the names of the fields
    ' from the recordset)
    blnHeaderRow = False

    ' Establish an EXCEL application object
    On Error Resume Next
    Set xlx = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
    Set xlx = CreateObject("Excel.Application")
    blnEXCEL = True
    End If
    Err.Clear
    On Error GoTo 0

    ' Change True to False if you do not want the workbook to be
    ' visible when the code is running
    xlx.Visible = False

    ' Create a new EXCEL workbook
    Set xlw = xlx.Workbooks.Add(CurrentProject.Path & "\Master.xltm")

    ' Rename the first worksheet in the EXCEL file to be the first 31
    ' characters of the string in the strRecordsetDataSource variable
    Set xls = xlw.Worksheets(1)
    xls.Name = "Sheet1" 'Trim(Left(strRecordsetDataSource, 31))

    ' Replace A1 with the cell reference of the first cell into which the
    ' headers will be written (blnHeaderRow = True), or into which the data
    ' values will be written (blnHeaderRow = False)
    Set xlc = xls.Range("A23")

    Set dbs = CurrentDb()

    Set rst = dbs.OpenRecordset(strRecordsetDataSource, dbOpenDynaset, dbReadOnly)

    If rst.EOF = False And rst.BOF = False Then
    ' Write the header row to worksheet
    If blnHeaderRow = True Then
    For lngColumn = 0 To rst.Fields.Count - 1
    xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Name
    Next lngColumn
    Set xlc = xlc.Offset(1, 0)
    End If

    ' copy the recordset's data to worksheet
    xlc.CopyFromRecordset rst




    'Copy A Range of Data
    Worksheets("Sheet1").Range("j15:q15").Copy

    'PasteSpecial Values Only
    Worksheets("Sheet1").Range("j18").PasteSpecial Paste:=xlPasteValues

    'Clear Clipboard (removes "marching ants" around your original data set)
    'Application.CutCopyMode = False

    End If

    Sheets("Sheet1").Range("e22").Copy (Sheets("Sheet1").Range("e23:e3000"))


    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing

    ' Save and close the EXCEL file, and clean up the EXCEL objects
    Set xlc = Nothing
    Set xls = Nothing
    xlw.SaveAs strPathFileName

    xlw.Close False

    Set xlw = Nothing
    If blnEXCEL = True Then xlx.Quit
    Set xlx = Nothing

    MsgBox "Excel files have been uploaded.", vbOKOnly


    End Sub

  5. #20
    pbaldy's Avatar
    pbaldy is online now Who is John Galt?
    Windows XP Access 2007
    Join Date
    Feb 2010
    Location
    Nevada, USA
    Posts
    22,518
    That's an odd error, seems like the only difference is you're copying an xlsm file instead of an xlsx file. Have you tried with the template as an xlsx, just for testing? The code I posted is running daily sending an email with multiple attachments, one for each account. It works flawlessly, so should work here unless I cut too much out when trying to get it down to the essentials. If you're still stuck, can you attach the db and the template file here?
    Paul (wino moderator)
    MS Access MVP 2007-2019
    www.BaldyWeb.com

  6. #21
    ebrommhead is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Nov 2012
    Location
    Mississauga
    Posts
    28
    Many thanks both Paul and Steve for your input. Paul, I created an .xlsx file to act as the template and had to make a few other tweaks on the worksheet vba and it now creates a file for each rep with the proper numbers inside.

    Grrrrrrrrrrrrrreat!!!

  7. #22
    pbaldy's Avatar
    pbaldy is online now Who is John Galt?
    Windows XP Access 2007
    Join Date
    Feb 2010
    Location
    Nevada, USA
    Posts
    22,518
    Excellent. Happy to help!
    Paul (wino moderator)
    MS Access MVP 2007-2019
    www.BaldyWeb.com

  8. #23
    ssanfu is offline Master of Nothing
    Windows 7 32bit Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    You have
    Code:
    ' Replace C:\Filename.xls with the actual path and filename
    ' that will be used to save the new EXCEL file into which you
    ' will write the data
    strPathFileName = CurrentProject.Path & "\excelfilestorepsforinputdata\" & "ZZ_Plan_Sales.xlsx"
    
    and
    
    ' Create a new EXCEL workbook
    Set xlw = xlx.Workbooks.Add(CurrentProject.Path & "\Master.xltm")
    What is \excelfilestorepsforinputdata" & "ZZ_Plan_Sales.xlsx used for?


    You said you want to have the data in the macro enabled workbook (a template?).
    Do you want the workbooks named something like "Tom_Jones_Master.xlsm"? It appears that you have one field for the name...??



    BTW, In future, please post code between CODE tags to retain indentation and readability (the # in the quick reply menu).

  9. #24
    ebrommhead is offline Novice
    Windows 7 64bit Access 2010 64bit
    Join Date
    Nov 2012
    Location
    Mississauga
    Posts
    28
    Thanks for your help Steve. The code is now working the way I would like it to.

  10. #25
    ssanfu is offline Master of Nothing
    Windows 7 32bit Access 2010 32bit
    Join Date
    Sep 2010
    Location
    Anchorage, Alaska, USA
    Posts
    9,664
    Great. Happy you were able to sort it out...

Page 2 of 2 FirstFirst 12
Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 1
    Last Post: 04-04-2017, 06:54 AM
  2. Replies: 7
    Last Post: 08-29-2014, 12:02 PM
  3. Uploading data from email to database?
    By MikeWP318 in forum Forms
    Replies: 1
    Last Post: 11-01-2011, 03:14 PM
  4. Replies: 1
    Last Post: 05-19-2011, 10:42 PM
  5. Replies: 3
    Last Post: 01-25-2011, 09:50 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums