none
Export data to Excel in a specific format? RRS feed

  • 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.



    • Edited by InnVis Saturday, August 10, 2019 9:35 PM EDITS
    Thursday, August 8, 2019 11:47 PM

All replies

  • 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.

    Tuesday, August 13, 2019 4:20 AM
  • 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?
    Wednesday, August 14, 2019 12:19 AM
  • 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.

    Wednesday, August 14, 2019 3:50 AM
  • Wednesday, August 14, 2019 8:08 PM
  • 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

    • Marked as answer by InnVis Friday, August 30, 2019 12:43 PM
    • Unmarked as answer by InnVis Thursday, September 5, 2019 6:03 PM
    Thursday, August 22, 2019 7:31 AM
  • This is very helpful, thank you! I will try this out today and update to see how it works.
    Thursday, August 22, 2019 2:21 PM
  • 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

    • Edited by InnVis Thursday, September 5, 2019 6:04 PM
    Thursday, September 5, 2019 6:02 PM