Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

Export Access Records to Excel

Posted on 2014-02-19
2
Medium Priority
?
572 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 600 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 93

Accepted Solution

by:
Patrick Matthews earned 1400 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

Nothing ever in the clear!

This technical paper will help you implement VMware’s VM encryption as well as implement Veeam encryption which together will achieve the nothing ever in the clear goal. If a bad guy steals VMs, backups or traffic they get nothing.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Access is a place to store data within tables and represent this stored data using multiple database objects such as in form of macros, forms, reports, etc. After a MS Access database is created there is need to improve the performance and…
Explore the ways to Unlock VBA Project Password Excel 2010 & 2013 documents. Go through the article and perform the steps carefully to remove VBA Excel .xls file.
Using Microsoft Access, learn some simple rules for how to construct tables in a relational database. Split up all multi-value fields into single values: Split up fields that belong to other things into separate tables: Make sure that all record…
This lesson discusses how to use a Mainform + Subforms in Microsoft Access to find and enter data for payments on orders. The sample data comes from a custom shop that builds and sells movable storage structures that are delivered to your property. …

824 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