• Status: Solved
  • Priority: High
  • Security: Public
  • Views: 30
  • Last Modified:

Create individual Excel workbooks representing provider name based on an Access table

I need to create individual Excel workbooks representing provider name based on an Access table. I need to loop through the table and create individual workbooks base on like provider names (provider name is a field in the table). I would like to save to the workbooks to a specified folder with the name of the provider. I have attached the sample table . Can you provide some sample code? Thanks
AccessTable.xlsx
0
shieldsco
Asked:
shieldsco
1 Solution
 
PatHartmanCommented:
Create a query that selects the providers you want.  Open the recordset and as you read each record, create the output file.  Here is sample code from one of my apps that does what you need.  It creates .pdf's.  You would use the same technique but create Excel files.  It uses FSO (File System Object) to create the dirctories and so you will need a reference to the "Microsoft Scripting Runtime" and possibly the "Microsoft Office 16.0 Object Library".  The Office 16.0 might be a different version for you depending on what version of Office you are using.  Just choose the version you have installed.

To control the exports, use a query that references a hidden control on your form.  Inside the code loop, as you read each new provider, place the ProviderID in the hidden control.  That way when you use the TransferSpreadsheet method to export the query, only the records for the specific provider will be included.

Private Sub cmdBlueRptPDF_Click()
    Dim db As DAO.Database
    Dim qd As DAO.QueryDef
    Dim rs As DAO.Recordset
    Dim td As DAO.TableDef
    Dim sPath As String
    Dim sRepPath
    Dim sDate As String
    Dim RecCount As Long
    Dim sFileName As String
    
    Dim FSO As New FileSystemObject
    
    DoCmd.RunMacro "mWarningsOff"
    
    
    sDate = Format(Date, "yyyymmdd")
    
    If Right(Me.txtPath, 1) = "\" Then
        sPath = Me.txtPath
    Else
        sPath = Me.txtPath & "\"
    End If
    
   On Error GoTo Error_Proc

    Set db = CurrentDb
    Set qd = db.QueryDefs!qUniqueReps
        qd.Parameters("[forms]![MainForm]![cboProductionID]") = Me.cboProductionID             ' "[forms]![MainForm]![cboProductionID]"
        qd.Parameters("[forms]![MainForm]![txtFromDT]") = Me.txtFromDT                   ' "[forms]![MainForm]![txtFromDT]"
    Set rs = qd.OpenRecordset

    Me.txtWhichRpt = "PDF"
    Do Until rs.EOF
        Me.txtRepID = rs!RepID
        Call BuildSQL
        sRepPath = sPath & rs!CallCenterCode & "\"  'can only add one level at a time
        If FSO.FolderExists(sRepPath) Then
        Else
            FSO.CreateFolder (sRepPath)
        End If
        sRepPath = sRepPath & rs!RepID & "\"        'can only add one level at a time
        If FSO.FolderExists(sRepPath) Then
        Else
            FSO.CreateFolder (sRepPath)
        End If
        
        sFileName = sRepPath & Format(Date, "yyyymmdd") & "_" & sDate & "_" & "BlueRpt_" & rs!CallCenterCode & "_" & rs!RepID & "_" & rs!Rep & ".pdf"
        DoCmd.OutputTo acOutputReport, "rptProfile", acFormatPDF, sFileName, False
        
        sFileName = sPath & Format(Date, "yyyymmdd") & "_" & sDate & "_" & "BlueRpt_" & rs!CallCenterCode & "_" & rs!RepID & "_" & rs!Rep & ".pdf"
        DoCmd.OutputTo acOutputReport, "rptProfile", acFormatPDF, sFileName, False
        
        rs.MoveNext
    Loop

    Me.txtRepID = Null
    Me.txtWhichRpt = "RPT"
    sFileName = sPath & Format(Date, "yyyymmdd") & "_" & sDate & "_" & "BlueRpt_ALL" & ".pdf"
    Call BuildSQL
    DoCmd.OutputTo acOutputReport, "rptProfile", acFormatPDF, sFileName, False      'print entire report
    
    MsgBox "Complete", vbOKOnly
    
Exit_Proc:
   On Error GoTo 0
   Set FSO = Nothing
   DoCmd.RunMacro "mWarningsOn"
   Exit Sub

Error_Proc:

    Select Case Err.Number
        Case 2501
            Resume Next
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdBlueRptPDF_Click of VBA Document Form_MainForm"
    End Select
    Resume Exit_Proc
    Resume

End Sub

Public Sub BuildSQL()
    Dim strWHERE    As String
    Dim strSQL      As String
    
    strWHERE = "WHERE (PR.DateCreated > #" & Me.txtFromDT & "#)"
    If Me.txtRepID & "" = "" Then
    Else
        strWHERE = strWHERE & " AND (q.RepID = " & Me.txtRepID & ")"
    End If
    strSQL = "SELECT PR.ProductionScheduleID, q.Rank, q.CallID, q.Tier1Score, q.Tier1OriginalScore, q.Tier1Comments, q.Tier2Score, q.Tier2OriginalScore, q.Tier2Comments, "
    strSQL = strSQL & " q.Tier3Score, Tier3OriginalScore, q.Tier3Comments, q.CompositeScore, q.Rep, q.RepID, "
    strSQL = strSQL & " PS.MonthCode, q.CallCenterID, PR.DateCreated, PR.DateCreated, RunType, [forms]![MainForm]![txtRepID] AS formRepID "
    strSQL = strSQL & " FROM (ProfileReportsCreated AS PR INNER JOIN qryCallScoreDashBoard AS q ON (PR.RepID = q.RepID) AND (PR.ProductionScheduleID = q.ProductionScheduleID)) "
    strSQL = strSQL & " INNER JOIN ProductionSchedule AS PS ON PR.ProductionScheduleID = PS.ProductionScheduleID"

    Me.txtSQL = strSQL & " " & strWHERE
End Sub

Open in new window

0

Join & Write a Comment

Featured Post

Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now