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
shieldscoAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.