Solved

Export Access Records to Excel

Posted on 2014-02-19
2
560 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

Free Tool: IP Lookup

Get more info about an IP address or domain name, such as organization, abuse contacts and geolocation.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
As tax season makes its return, so does the increase in cyber crime and tax refund phishing that comes with it
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …

679 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