Export data to Excel in a specific format?

Question

Hey guys, I have managed to do this in the past, but with a much less complicated layout - HELP! A little background, I'm a clinical data analyst, my job consists of gathering and analyzing massive amounts of medical information to ensure best practice and plan for quality improvements. Here it comes: 

I have a form that we enter specific data daily during a meeting. After the meeting we input the data into an excel and email it to all managers. We can only collect data M-F because of our working hours and the data that we collect is from the day prior, in other words if we have a meeting on Wednesday we are discussing Tuesday's data. Anyways, on Mondays we gather the data from Friday, Saturday, and Sunday (as you can see in the image represented differently). OK so here's the problem, I already made the form and the tables and a query where I entered the format of most of the records, but now it's about exporting the records in a particular order on the excel sheet and the records to only export 7 days at a time displaying today's record replacing the previous record, but still displaying the complete week. So for example today our table displayed the data for Friday, Saturday(on the Monday tab), Sunday(on the Monday tab) , Monday(on the Monday tab) , Tuesday(Monday's Data on the Tuesday tab), Wednesday(Tuesday's data on the Wednesday tab), Thursday (Wednesday's data on the Thursday tab), and Friday (previous Thursday's data waiting for update from this week) - refer to picture for more detail.

This is the wonderful code I use to export data to Excel: 

Private Sub cmdHuddleReport_Click()
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim db As DAO.Database
Dim rsEXHuddle As DAO.Recordset
Dim strSQL As String
Dim x As Long

On Error GoTo errHandler
Set db = CurrentDb()
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add

  If IsNull(txtshDate) Or Me.txtshDate.Value = "" Then
        MsgBox "NULL BOX", vbCritical, "REQUIRED FIELD"
        Else
        
        strSQL = "SELECT [CAP] AS CPCT , " _
        & " [DISCHARGES] AS DCHRGS , " _
        & " [EarlyDC] AS EDSG , " _
        & " [LateDC] AS LDC , " _
        & " [shEDDecisionToDepart] AS EDDTD , " _
        & " [shCVEarlyDCPrediction] AS CVEDCP , " _
        & " [shSurg_TranEarlyDCPrediction] AS STEDCP , " _
        & " [shPsych_RehabEarlyDCPrediction] AS PREDCP , " _
        & " [shMed_OncEarlyDCPrediction] AS MOEDCP , " _
        & " [WOCN] AS WNDCR , " _
        & " [shLateLabAssist] AS LABAST , " _
        & " [EVS_PM_STAFFING] AS EVSSTFNG , " _
        & " [shRTWalker] AS RTWLKR " _
        & " FROM qryServiceHuddleReport"
          
        End If
        
        Set rsEXHuddle = db.OpenRecordset(strSQL, dbOpenSnapshot)
        Set xlWS = xlWB.Sheets(1)

        xlWS.Cells(1, 1) = "CAPACITY %"
        xlWS.Cells(1, 2) = "TOTAL DISCHARGES #s"
        xlWS.Cells(1, 3) = "Before / <1pm"
        xlWS.Cells(1, 4) = "After/>5pm"
        xlWS.Cells(1, 5) = "ED Decision to Depart (minutes)"
        xlWS.Cells(1, 6) = "Card/Vasc"
        xlWS.Cells(1, 7) = "Surg/Trans"
        xlWS.Cells(1, 8) = "Psych/Rehab"
        xlWS.Cells(1, 9) = "Med/Onc"
        xlWS.Cells(1, 10) = "WOCN: Total; New; Unseen >24hrs"
        xlWS.Cells(1, 11) = "LAB: Nurse Draw Assists waiting >1hr as of 10:30"
        xlWS.Cells(1, 12) = "EVS pm staffing"
        xlWS.Cells(1, 13) = "RT Walkers"
        
       ' With rsEXHuddle
       ' xlWS.Cells(1, 1) = !DONTKNO
       ' End With
        
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        'xlWS.Cells(1, 1) = "DATE"
        'xlWS.Cells(1, 2) = "UNIT"
        'xlWS.Cells(1, 3) = "AREA"
        'xlWS.Cells(1, 4) = "STANDARD REQUIREMENT"
        'xlWS.Cells(1, 5) = "NON-CONFORMITY DETAILS"
        'xlWS.Cells(1, 6) = "CORRECTIVE ACTION"
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        
        'add data
        xlWS.Range("A2").CopyFromRecordset rsEXHuddle
        x = rsEXHuddle.RecordCount
        rsEXHuddle.Close

        'format
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).HorizontalAlignment = 3
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(x + 1, 2)).HorizontalAlignment = xlCenter
        xlWS.Range(xlWS.Cells(2, 3), xlWS.Cells(x + 1, 6)).HorizontalAlignment = xlLeft
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(x + 1, 13)).Borders.LineStyle = xlContinuous
        xlWS.Columns("A:M").AutoFit

'remove extra tabs
If xlWB.Sheets.Count > 1 Then
With xlWB
On Error Resume Next
    .Sheets("Sheet1").Delete
    .Sheets("Sheet2").Delete
    .Sheets("Sheet3").Delete
On Error GoTo 0
End With
Else
'xlWB.Close , False
xlApp.Visible = True
Exit Sub
End If

errExit:
    Set rsEXHuddle = Nothing
    Set db = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Sub
    
errHandler:
    MsgBox Err.Number & ". " & Err.Description
    Resume errExit
    Resume
End Sub

This is the code that works at the moment but the columns and rows are reversed. I'm having 2 issues essentially: 1). I want to display rows and columns as they are on the picture (so i need to reverse this function's display. 2). I need to be able to organize the data from M-F even if the following day is from a previous date, i.e. If we're displaying current data from this Tuesday on the Wednesday column, the data from last week's Thursday (Wednesday's information) and Friday (Thursday's information) columns still show until it is updated the following day.

Answer 1

Hi,

You got the rows and columns mixed up.

It should be Cells(Row,Column). This code....

xlWS.Cells(1, 2) = "TOTAL DISCHARGES #s"

indicates that you want Row1/Column2......so you're saying it's not what you wanted?

In this case, it should be....

xlWS.Cells(5, 1) = "TOTAL DISCHARGES #s"

I can't help you much as it requires hand holding code by code, line by line until you get the desired results. I myself had done it but it took many months.

Use Access Help, it does help and do a search on the web.

Answer 2

Thanks for the reply, but the code you're referring to are just headings. It is not the data being copies from the database (i.e the SQL statement). How do I make that data copy over in the way I choose?

Answer 3

Hi,

Below is a sample code.

Dim db as DAO.Database

Dim rs As DAO.RecordSet

Dim xl As Object

Dim x As Long

x = 0   'Starting Point of Rows in Excel

Set xl = CreateObject("Excel.Application")

xl.Workbooks.Open ("Path to an Existing File")

Set db = CurrentDb
 'Set qdf = db.QueryDefs("MyNamedQueyInAccess")   'or this
set rs = db.OpenRecordSet("Your SQL String Here")

rs.MoveLast
rs.MoveFirst

 '------If rs.EOF then Exit Sub or Function ----- do this if needed.
   ''----- Check Records -----------------------
   'If rs.RecordCount = 0 Then
   'MsgBox "There is/are no Data/Records.", vbInformation, "My Sub/Function/Whatever"
   'xl.Application.DisplayAlerts = False
   'xl.Application.Quit
   'xl.Application.DisplayAlerts = True
   'GoTo ErrorExit    'your exit routine label
   'End If
   ''-------------------------------------------

Do Until rs.EOF

   x = x + 1

   xl.Sheets(1).Cells((x + 1), 2).Value = rs(0)

   rs.MoveNext

Loop

"x" is used to position the next Row in Excel. "y" can be used to position the next column. I did not include it.

"xl.Sheets(1)" - is the Sheet name or "Sheet1" in this case.

".Cells((x + 1)" is the row you want the recordset value to be placed.

" ,2)" is the Column which also can be modified for "y".

".Value = rs.(0)" is the recordset value and

"rs.(0)" is the starting recordset Field Number or you could use this "rs.("MyField")" or "rs!MyField".

You'll need to debug line by line on a sample. It will take a long time to get it right because you'll encounter a lot of errors.

You might need to save and close.

    '-----Save and Display Result in Excel-------------------------------------------------
    xl.Application.DisplayAlerts = False
    xl.Application.Save
    xl.Application.DisplayAlerts = True
    xl.Visible = True    'Show Excel if need here
    '--------------------------------------------------------------------------------------

And make sure the objects are destroyed if errors are encountered and exiting code.

MyExitCode:
On Error Resume Next
xl.Close
rs.Close
db.Close
Set xl = Nothing
Set rs = Nothing

One most important thing is the Windows Task Manager, check any Excel that is not closed and end task to avoid errors.

Answer 4

Hi InnVis

What about export to an Excel Template?

https://social.msdn.microsoft.com/Forums/en-US/24c4c9f9-39b2-4ed8-aea3-d4ed86d76f21/export-a-report-to-an-excel-template-ac2007?forum=accessdev

---

Cheers // Peter Forss Stockholm

Answer 5

Well i think you have to take a step back

Is the query gives you the correct structure of fields/values...to say it simpler when you run the query from Access is it as you want it.....probably not..

So you want to tranpose columns to rows...

One way would be to work on the Access side on the query...maybe you need to create a cross-tab query instead of simple query...

but since you already have the code just

With rst
While Not .EOF
For i =0 to .Fields.Count-1
 xlWS.Cells(Row, Column)=.Fields(i)
.MoveNext
Wend
End With
rst.Close
set rst=Nothing

Just pay attention to the Row,Column what you want them to be and just adjust accordingly

Answer 6

This is very helpful, thank you! I will try this out today and update to see how it works.

Answer 7

Hey John, tried using this code but it seems to not do anything with the records. Any thoughts?

This is the current state of the code with your suggestion:

Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim db As DAO.Database
Dim rsEXHuddle As DAO.Recordset
Dim strSQL As String
Dim x As Long
Dim i As Integer

On Error GoTo errHandler
Set db = CurrentDb()
Set xlApp = CreateObject("Excel.Application")
Set xlWB = xlApp.Workbooks.Add

  If IsNull(txtshDate) Or Me.txtshDate.Value = "" Then
        MsgBox "NULL BOX", vbCritical, "REQUIRED FIELD"
        Else
        
        strSQL = "SELECT [CAP] AS CPCT , " _
        & " [DISCHARGES] AS DCHRGS , " _
        & " [EarlyDC] AS EDSG , " _
        & " [LateDC] AS LDC , " _
        & " [shEDDecisionToDepart] AS EDDTD , " _
        & " [shCVEarlyDCPrediction] AS CVEDCP , " _
        & " [shSurg_TranEarlyDCPrediction] AS STEDCP , " _
        & " [shPsych_RehabEarlyDCPrediction] AS PREDCP , " _
        & " [shMed_OncEarlyDCPrediction] AS MOEDCP , " _
        & " [WOCN] AS WNDCR , " _
        & " [shLateLabAssist] AS LABAST , " _
        & " [EVS_PM_STAFFING] AS EVSSTFNG , " _
        & " [shRTWalker] AS RTWLKR " _
        & " FROM qryServiceHuddleReport"
          
        End If
        
        Set rsEXHuddle = db.OpenRecordset(strSQL, dbOpenSnapshot)
        Set xlWS = xlWB.Sheets(1)

        xlWS.Cells(1, 1) = "CAPACITY %"
        xlWS.Cells(1, 2) = "TOTAL DISCHARGES #s"
        xlWS.Cells(1, 3) = "Before / <1pm"
        xlWS.Cells(1, 4) = "After/>5pm"
        xlWS.Cells(1, 5) = "ED Decision to Depart (minutes)"
        xlWS.Cells(1, 6) = "Card/Vasc"
        xlWS.Cells(1, 7) = "Surg/Trans"
        xlWS.Cells(1, 8) = "Psych/Rehab"
        xlWS.Cells(1, 9) = "Med/Onc"
        xlWS.Cells(1, 10) = "WOCN: Total; New; Unseen >24hrs"
        xlWS.Cells(1, 11) = "LAB: Nurse Draw Assists waiting >1hr as of 10:30"
        xlWS.Cells(1, 12) = "EVS pm staffing"
        xlWS.Cells(1, 13) = "RT Walkers"
        
       ' With rsEXHuddle
       ' xlWS.Cells(1, 1) = !DONTKNO
       ' End With
        
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        'xlWS.Cells(1, 1) = "DATE"
        'xlWS.Cells(1, 2) = "UNIT"
        'xlWS.Cells(1, 3) = "AREA"
        'xlWS.Cells(1, 4) = "STANDARD REQUIREMENT"
        'xlWS.Cells(1, 5) = "NON-CONFORMITY DETAILS"
        'xlWS.Cells(1, 6) = "CORRECTIVE ACTION"
        'xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).Font.Bold = True
        
        'add data
        xlWS.Range("A2").CopyFromRecordset rsEXHuddle
        x = rsEXHuddle.RecordCount
        
        With rsEXHuddle
        While Not .EOF
        For i = 0 To .Fields.Count - 1
        Next
        xlWS.Cells(1, 1) = .Fields(i)
        .MoveNext
        Wend
        End With
        rsEXHuddle.Close
        

        'format
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(1, 6)).HorizontalAlignment = 3
        xlWS.Range(xlWS.Cells(2, 1), xlWS.Cells(x + 1, 2)).HorizontalAlignment = xlCenter
        xlWS.Range(xlWS.Cells(2, 3), xlWS.Cells(x + 1, 6)).HorizontalAlignment = xlLeft
        xlWS.Range(xlWS.Cells(1, 1), xlWS.Cells(x + 1, 13)).Borders.LineStyle = xlContinuous
        xlWS.Columns("A:M").AutoFit

'remove extra tabs
If xlWB.Sheets.Count > 1 Then
With xlWB
On Error Resume Next
    .Sheets("Sheet1").Delete
    .Sheets("Sheet2").Delete
    .Sheets("Sheet3").Delete
On Error GoTo 0
End With
Else
'xlWB.Close , False
xlApp.Visible = True
Exit Sub
End If

errExit:
    Set rsEXHuddle = Nothing
    Set db = Nothing
    Set xlWS = Nothing
    Set xlWB = Nothing
    Set xlApp = Nothing
    Exit Sub
    
errHandler:
    MsgBox Err.Number & ". " & Err.Description
    Resume errExit
    Resume