Solved

Export Access Records to Excel

Posted on 2014-02-19
2
553 Views
Last Modified: 2014-02-24
I have an Access Table that contains monthly data. There is 1 record for each day, location and account number. It looks something like this (I only included 3 days of data here as opposed to 31):

DateField    Location  AccountNo  Amount
1/1/2013       MA           100                $  10
1/2/2013       MA           100                $500  
1/3/2013       MA           100                $200
1/1/2013       MA           200                $  50
1/2/2013       MA           200                $750
1/3/2013       MA           200                $300
1/1/2013       NJ             100                $  10
1/2/2013       NJ             100                $500  
1/3/2013       NJ             100                $200
1/1/2013       NJ             200                $  50
1/2/2013       NJ             200                $750
1/3/2013       NJ             200                $300

I need to export this data to Excel such that each location's data will appear in a separate tab. The expected results for tab1 (the MA tab in this instance) in Excel would be:

DateField    Location  AccountNo  Amount   AccountNo  Amount
1/1/2013         MA             100              $  10           200             $  50
1/2/2013         MA             100              $500           200             $750    
1/3/2013         MA             100              $200           200             $300  

The expected results for tab2 (the NJ tab in this instance) in Excel would be

DateField    Location  AccountNo  Amount   AccountNo  Amount
1/1/2013         NJ             100                $  10          200             $  50
1/2/2013         NJ             100                $500          200             $750    
1/3/2013         NJ             100                $200          200             $300

Ideally, each tab would be named for its location. But if I can just get the data into separate tabs in the format above, I'd be happy. I could then manually rename each tab (from, say Sheet1 to "NJ", etc). Thanks
0
Comment
Question by:dbfromnewjersey
2 Comments
 
LVL 38

Assisted Solution

by:Jim P.
Jim P. earned 150 total points
ID: 39870596
This code is designed to take a table and export based on the first character of the last name to an Excel SS that that has an overall full list worksheet and then a separate sheet for each letter. But it should be easily be modifiable to do it by the location.

Dim SQL As String
Dim DB As DAO.Database
Dim ControlRS As DAO.Recordset
Dim RS As DAO.Recordset
Dim Qry As DAO.QueryDef

Dim XL As New Excel.Application
Dim BookNm As Excel.Workbook
Dim SheetNm As String

Dim I As Integer

Dim FileNameAndPath As String
Dim FolderName As String
Dim ExportFileName As String

FacCode = Trim(Forms("Main_Form").FacCdTxtBox.Value)
FolderName = Create_Export_Path(FacCode)
FileNameAndPath = FolderName & FacCode & "_Missing_Res_SS.xls"

XL.Visible = True
XL.DisplayAlerts = False

Set DB = CurrentDb()
Set BookNm = XL.Workbooks.Add
With BookNm
        .SaveAs FileName:=FileNameAndPath
        .Sheets("sheet2").Delete
        .Sheets("sheet3").Delete
        
        SheetNm = "Full_List"
        SQL = "SELECT LocDemographicsTbl.Facility_code, LocDemographicsTbl.Client_id_number as ACC_MRN, AddOnResDataHold.Client_id_number as AON_MRN, " & _
            "LocDemographicsTbl.Last_name, NZ(LocDemographicsTbl.Last_name,'ZZ Unknown'), LocDemographicsTbl.Date_of_birth, Chr(34) & LocDemographicsTbl.Social_security_number & Chr(34) As SSN " & _
            "FROM LocDemographicsTbl  " & _
            "LEFT JOIN AddOnResDataHold " & _
            "ON LocDemographicsTbl.Client_id_number = AddOnResDataHold.mrn_ACC " & _
            "WHERE NZ(LocDemographicsTbl.Last_name,'ZZ Unknown') <>  '' " & _
            "ORDER BY NZ(LocDemographicsTbl.Last_name,'ZZ Unknown'), NZ(LocDemographicsTbl.First_name,'') "
        
        Set RS = DB.OpenRecordset(SQL)
        .Sheets.Add after:=Sheets(Sheets.Count)
        .Sheets(Sheets.Count).Name = SheetNm
        'Exporting the header row
        For I = 0 To RS.Fields.Count - 1
            .Sheets(SheetNm).Cells(1, I + 1).Value = RS.Fields(I).Name
        Next
        .Sheets(SheetNm).Range(.Sheets(SheetNm).Cells(1, 1), .Sheets(SheetNm).Cells(1, RS.Fields.Count)).Font.Bold = True
        '.Sheets(SheetNm).Range(.Sheets(SheetNm).Cells(1, 1), .Sheets(SheetNm).Cells(1, RS.Fields.Count)).Format.Align = "center"

        'COPY THE TABLE
        .Sheets(SheetNm).Range("A2").CopyFromRecordset RS

        RS.Close

        SQL = "SELECT Left(Last_name,1) as ShtName " & _
            "FROM LocDemographicsTbl " & _
            "WHERE IsNull(Last_name) = False " & _
            "GROUP BY Left(Last_name,1) " & _
            "ORDER BY Left(Last_name,1) "
        
        Set ControlRS = DB.OpenRecordset(SQL)
        
        
        If ControlRS.EOF = False Then
            ControlRS.MoveFirst
            Do Until ControlRS.EOF = True
                SheetNm = ControlRS!ShtName
                SQL = "SELECT LocDemographicsTbl.Facility_code, LocDemographicsTbl.Client_id_number as ACC_MRN, AddOnResDataHold.Client_id_number as AON_MRN, " & _
                    "LocDemographicsTbl.Last_name, NZ(LocDemographicsTbl.Last_name,''), LocDemographicsTbl.Date_of_birth, Chr(34) & LocDemographicsTbl.Social_security_number & Chr(34) As SSN " & _
                    "FROM LocDemographicsTbl  " & _
                    "LEFT JOIN AddOnResDataHold " & _
                    "ON LocDemographicsTbl.Client_id_number = AddOnResDataHold.mrn_ACC " & _
                    "WHERE Left(Nz(LocDemographicsTbl.Last_name,''),1) =  " & Chr(34) & ControlRS!ShtName & Chr(34) & " " & _
                    "ORDER BY LocDemographicsTbl.Last_name, LocDemographicsTbl.First_name "

                Set RS = DB.OpenRecordset(SQL)
                .Sheets.Add after:=Sheets(Sheets.Count)
                .Sheets(Sheets.Count).Name = SheetNm
                'Exporting the header row
                For I = 0 To RS.Fields.Count - 1
                    .Sheets(SheetNm).Cells(1, I + 1).Value = RS.Fields(I).Name
                Next
                .Sheets(SheetNm).Range(.Sheets(SheetNm).Cells(1, 1), .Sheets(SheetNm).Cells(1, RS.Fields.Count)).Font.Bold = True
                '.Sheets(SheetNm).Range(.Sheets(SheetNm).Cells(1, 1), .Sheets(SheetNm).Cells(1, RS.Fields.Count)).Format.Align = "center"
        
                'COPY THE TABLE
                .Sheets(SheetNm).Range("A2").CopyFromRecordset RS
         
        
                ControlRS.MoveNext
            Loop
        End If
    .Sheets("sheet1").Delete
End With

RS.Close

XL.ActiveWorkbook.Save
BookNm.Close
XL.Quit

Set XL = Nothing
Set RS = Nothing
Set ControlRS = Nothing
Set DB = Nothing

Open in new window

0
 
LVL 92

Accepted Solution

by:
Patrick Matthews earned 350 total points
ID: 39871160
The following code should do the trick.  It automatically adjusts to the number of locations and number of accounts to display.

Sub DoExport()
    
    Dim xlApp As Object 'Excel.Application
    Dim xlWb As Object 'Excel.Workbook
    Dim xlWs As Object 'Excel.Worksheet
    Dim SheetsNeeded As Long
    Dim SheetsInWb As Long
    Dim rsLocations As DAO.Recordset
    Dim rsExport As DAO.Recordset
    Dim CurrentLoc As String
    Dim CurrentMaxRank As Long
    Dim SheetsDone As Long
    Dim Headers() As Variant
    Dim Counter As Long
    Dim Sql As String
    
    With DoCmd
        .SetWarnings False
        .RunSQL "SELECT t1.DateField, t1.Location, t1.AccountNo, t1.Amount, Count(t2.Amount) AS Rank " & _
            "INTO tmpRank " & _
            "FROM SomeTable AS t1 INNER JOIN SomeTable AS t2 ON t1.AccountNo >= t2.AccountNo AND " & _
            "t1.DateField = t2.DateField AND t1.Location = t2.Location " & _
            "GROUP BY t1.DateField, t1.Location, t1.AccountNo, t1.Amount " & _
            "ORDER BY t1.DateField, t1.Location, t1.AccountNo, Count(t2.Amount);"
        .RunSQL "SELECT Location, Max(Rank) AS MaxRank " & _
            "INTO tmpLocations " & _
            "FROM tmpRank " & _
            "GROUP BY Location"
    End With
    
    Set rsLocations = CurrentDb.OpenRecordset("SELECT Location, MaxRank " & _
        "FROM tmpLocations " & _
        "ORDER BY Location")
        
    SheetsNeeded = DCount(1, "tmpLocations")
    
    Set xlApp = CreateObject("Excel.Application")
    SheetsInWb = xlApp.SheetsInNewWorkbook
    xlApp.SheetsInNewWorkbook = SheetsNeeded
    Set xlWb = xlApp.Workbooks.Add
    xlApp.Visible = True
    xlApp.SheetsInNewWorkbook = SheetsInWb

    Do Until rsLocations.EOF
        CurrentLoc = rsLocations!Location
        CurrentMaxRank = rsLocations!MaxRank
        SheetsDone = SheetsDone + 1
        ReDim Headers(1 To 1, 1 To 2 + 2 * CurrentMaxRank)
        Headers(1, 1) = "DateField"
        Headers(1, 2) = "Location"
        Sql = "SELECT t1.DateField, t1.Location"
        For Counter = 1 To CurrentMaxRank
            Headers(1, 1 + 2 * Counter) = "AccountNo"
            Headers(1, 2 + 2 * Counter) = "Amount"
            Sql = Sql & ", (SELECT t2.AccountNo " & _
                "FROM tmpRank t2 " & _
                "WHERE t2.DateField = t1.DateField AND t2.Location = t1.Location AND t2.Rank = " & Counter & ") AS Acct" & Counter
            Sql = Sql & ", (SELECT t2.Amount " & _
                "FROM tmpRank t2 " & _
                "WHERE t2.DateField = t1.DateField AND t2.Location = t1.Location AND t2.Rank = " & Counter & ") AS Amount" & Counter
        Next
        Sql = Sql & " FROM tmpRank t1 " & _
            "WHERE t1.Location = '" & CurrentLoc & "' " & _
            "GROUP BY t1.DateField, t1.Location " & _
            "ORDER BY t1.DateField, t1.Location;"
        Set xlWs = xlWb.Worksheets(SheetsDone)
        With xlWs
            .Range("a1").Resize(1, UBound(Headers, 2)) = Headers
            Set rsExport = CurrentDb.OpenRecordset(Sql)
            .Range("a2").CopyFromRecordset rsExport
            .Range("a:a").NumberFormat = "yyyy-mm-dd"
            .Range("1:1").Font.Bold = True
            .Columns.AutoFit
            On Error Resume Next
            .Name = CurrentLoc
            On Error GoTo 0
        End With
        With xlWb.Worksheets(1)
            .Range("a:a").NumberFormat = "yyyy-mm-dd"
            .Columns.AutoFit
        End With
        rsExport.Close
        Set rsExport = Nothing
        rsLocations.MoveNext
    Loop
    
    rsLocations.Close
    Set rsLocations = Nothing
    Set xlApp = Nothing
    
    With DoCmd
        .RunSQL "DROP TABLE tmpRank"
        .RunSQL "DROP TABLE tmpLocations"
        .SetWarnings True
    End With
    
End Sub

Open in new window

0

Featured Post

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

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…
In a multiple monitor setup, if you don't want to use AutoCenter to position your popup forms, you have a problem: where will they appear?  Sometimes you may have an additional problem: where the devil did they go?  If you last had a popup form open…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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.

708 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

18 Experts available now in Live!

Get 1:1 Help Now