Solved

Create Excel spreadsheet with 500 columns from Access crosstab query

Posted on 2011-02-17
5
654 Views
Last Modified: 2013-03-14
In Access 2010, I want to run a crosstab query and export the result to Excel. However, the crosstab doesn't work because it creates more than 255 columns. I suppose I could split the query into two (or more) queries that result in fewer than 256 columns, and then combine the two Excel spreadsheets into a single spreadsheet. However, that could become cumbersome if there are thousands of columns. It might also be tricky ensuring that the key value in the two Excel sheets is identical for each row.

0
Comment
Question by:gordonwwaugh
  • 3
  • 2
5 Comments
 
LVL 57
ID: 34919402

 That would be a code only solution because as you have found, the limit in Access for any output in a query is 255 columns.  That means you need to fetch the data yourself and feed it to Excel.

JimD.
0
 
LVL 57

Accepted Solution

by:
Jim Dettman (Microsoft MVP/ EE MVE) earned 500 total points
ID: 34919459

 And to give you an example of what I'm taking about, attached is code that produced a department report in Excel.

JimD.
Function GenOutOfDeptSpreadSheet(strFileName As String, intAdj As Integer) As Integer

    Dim oXL As Object        ' Excel application
    Dim oBook As Object      ' Excel workbook
    Dim oSheet As Object     ' Excel Worksheet
    
    Dim db As Database
    Dim qrydef As QueryDef
    Dim rstTC As Recordset
    Dim rstDept As Recordset
    
    Dim strRecord As String
            
    Dim strCurDepartment As String
    Dim strWorkDepartment  As String
    Dim lngCurEmpID As Long
    
    Dim strDept(100) As String
    Dim lngDeptRows(100, 2) As Long ' (X,1) = Starting row, (X, 2) is ending row
    Dim lngDeptCount As Long
    Dim lngCurDept As Long
    
    Dim lngCurRow As Long
    
    Dim lngK As Long
    Dim lngColumn As Long
    Dim lngCurColumn As Long
    Dim lngLastColumn As Long

    Const Routine = "GenOutOfDeptSpreadSheet"
    Const Version = "1.0.0"

    ' Delete last request file & open a new one.
    On Error Resume Next
    Kill strFileName
    DoEvents
    On Error GoTo GenOutOfDeptSpreadSheet_UnexpectedError
    
    'Start Excel and create a new workbook
    Set oXL = CreateObject("Excel.application")
    Set oBook = oXL.Workbooks.Add
    Set oSheet = oBook.Worksheets.Item(1)
    
    ' Make Excel Visible:
    'oXL.Visible = True

    Set db = CurrentDb()

    ' Get all possible departments for the columns
    Set rstDept = db.OpenRecordset("SELECT tblDepartment.DepartmentID FROM tblDepartment WHERE (((IsNumeric([DepartmentID])) = False)) ORDER BY tblDepartment.DepartmentID WITH OWNERACCESS OPTION;")
    lngDeptCount = 0
    Erase strDept()
     
     Do While Not rstDept.EOF
        lngDeptCount = lngDeptCount + 1
        strDept(lngDeptCount) = rstDept![DepartmentID]
        rstDept.MoveNext
    Loop
    
    ' Figure last column were working with
    lngLastColumn = lngDeptCount * 3 + 4
         
     ' Write Column headings.
    GoSub GenOutOfDeptSpreadSheet_PageHeadings
    
    ' Write one row per dept/employee
    If intAdj = True Then
      Set qrydef = db.QueryDefs("qrybasGenOutOfDeptAdj")
    Else
      Set qrydef = db.QueryDefs("qrybasGenOutOfDept")
    End If
    qrydef.Parameters(0) = Eval(qrydef.Parameters(0).Name)
    qrydef.Parameters(1) = Eval(qrydef.Parameters(1).Name)
    Set rstTC = qrydef.OpenRecordset(DB_OPEN_DYNASET)

    lngCurRow = 4
    strCurDepartment = ""
    lngCurDept = 0
    Erase lngDeptRows()
    
    If rstTC.RecordCount > 0 Then
      rstTC.MoveFirst
      Do Until rstTC.EOF
          ' New department?
          If rstTC![HomeDepartment] <> strCurDepartment Then GoSub GenOutOfDeptSpreadSheet_NewDept
          
          ' New Employee?
          If rstTC![EmpID] <> lngCurEmpID Then
            ' Move to a new row and write static columns
             lngCurRow = lngCurRow + 1
             lngCurEmpID = rstTC![EmpID]
          
            oSheet.Cells(lngCurRow, 1).Value = rstTC![PayRate]
            oSheet.Cells(lngCurRow, 2).Value = rstTC![Name]
            oSheet.Cells(lngCurRow, 3).Value = rstTC![EmpID]
            oSheet.Cells(lngCurRow, 4).Value = rstTC![HomeDepartment]
            
         End If
          
          ' Write record to spreadsheet
                      
          ' First find the column for this department.
          If NZ(rstTC![Department], "") = "" Then
            strWorkDepartment = rstTC![HomeDepartment]
          Else
            strWorkDepartment = rstTC![Department]
          End If
          
          lngColumn = 0
          For lngK = 1 To lngDeptCount
            If strWorkDepartment = strDept(lngK) Then
              lngColumn = lngK
              lngK = lngDeptCount
            End If
          Next lngK
          
          lngCurColumn = (lngColumn * 3) + 2
          If lngCurColumn > 4 Then
            With oSheet
                  .Cells(lngCurRow, lngCurColumn).Value = rstTC![HrsReg]
                  .Cells(lngCurRow, lngCurColumn + 1).Value = rstTC![OTHrs]
                  .Cells(lngCurRow, lngCurColumn + 2).Value = rstTC![Pay]
            End With
          End If

          ' Next record
          rstTC.MoveNext
      Loop
      
      ' Finish last department
      GoSub GenOutOfDeptSpreadSheet_NewDept
    End If

 
    ' Apply formatting to spreadsheet as a whole.
    With oSheet
          .Columns(1).Autofit
          .Columns(2).Autofit
          .Columns(3).Autofit
          .Columns(4).Autofit
          
          For lngK = 1 To lngDeptCount
            lngCurColumn = (lngK * 3) + 2
            .Columns(lngCurColumn).NumberFormat = "#,###.00"
            .Columns(lngCurColumn + 1).NumberFormat = "#,###.00"
            .Columns(lngCurColumn + 2).NumberFormat = "$###,###.00"
            .Columns(lngCurColumn + 2).ColumnWidth = 11
          Next lngK
    End With
    
    ' Save the sheet
    oSheet.SaveAs strFileName
    
    GenOutOfDeptSpreadSheet = True

GenOutOfDeptSpreadSheet_Exit:

    On Error Resume Next
    
    rstTC.Close
    Set rstTC = Nothing

    qrydef.Close
    Set qrydef = Nothing

    Set db = Nothing
    
    ' Close Excel with the Quit method on the Application object
    oXL.Quit
    
    Set oSheet = Nothing
    Set oBook = Nothing
    Set oXL = Nothing
    
    Exit Function

GenOutOfDeptSpreadSheet_UnexpectedError:
      UnexpectedError ModuleName, Routine, Version, Err, Error$
      
      On Error Resume Next
      DoEvents
      
      Resume GenOutOfDeptSpreadSheet_Exit
    
GenOutOfDeptSpreadSheet_NewDept:
      If strCurDepartment <> "" Then
        ' Save last row used for this department
        lngDeptRows(lngCurDept, 2) = lngCurRow
      
        With oSheet
        
            ' Write out the departments in the columns again
            lngCurRow = lngCurRow + 1
             For lngK = 1 To lngDeptCount
               lngCurColumn = (lngK * 3) + 2
               .Cells(lngCurRow, lngCurColumn).Value = strDept(lngK)
               .Range(.Cells(lngCurRow, lngCurColumn), .Cells(lngCurRow, lngCurColumn + 2)).Merge
            Next lngK
            
            .Range(.Cells(lngCurRow, 1), .Cells(lngCurRow, 4)).Merge
            .Range(.Cells(lngCurRow, 5), .Cells(lngCurRow, lngLastColumn)).Borders.Weight = 3
            .Range(.Cells(lngCurRow, 5), .Cells(lngCurRow, lngLastColumn)).Font.Bold = True
            .Range(.Cells(lngCurRow, 5), .Cells(lngCurRow, lngLastColumn)).HorizontalAlignment = 3
            
            ' Now do department total line
            lngCurRow = lngCurRow + 1
            For lngK = 1 To (lngDeptCount * 3)
              lngCurColumn = lngK + 4
              .Cells(lngCurRow, lngCurColumn).Value = "=SUM(R" & lngDeptRows(lngCurDept, 1) & "C" & lngCurColumn & ":R" & lngDeptRows(lngCurDept, 2) & "C" & lngCurColumn & ")"
            Next lngK
            
            .Range(.Cells(lngCurRow, 1), .Cells(lngCurRow, 4)).Merge
            .Cells(lngCurRow, 1).Value = "TOTALS FROM " & strCurDepartment & " TO:"
            .Cells(lngCurRow, 1).HorizontalAlignment = 4
            .Range(.Cells(lngCurRow, 1), .Cells(lngCurRow, lngLastColumn)).Interior.ColorIndex = 33
            .Range(.Cells(lngCurRow, 1), .Cells(lngCurRow, lngLastColumn)).Font.Bold = True
            
        End With
        
        lngCurRow = lngCurRow + 1
      End If
      
      If Not rstTC.EOF Then
        ' Start new department
        lngCurDept = lngCurDept + 1
        strCurDepartment = rstTC![HomeDepartment]
        lngDeptRows(lngCurDept, 1) = lngCurRow
        
        lngCurEmpID = rstTC![EmpID]
        oSheet.Cells(lngCurRow, 1).Value = rstTC![PayRate]
        oSheet.Cells(lngCurRow, 2).Value = rstTC![Name]
        oSheet.Cells(lngCurRow, 3).Value = rstTC![EmpID]
        oSheet.Cells(lngCurRow, 4).Value = rstTC![HomeDepartment]

      End If
    
    Return

GenOutOfDeptSpreadSheet_PageHeadings:
      With oSheet
      
        .Cells(1, 5) = "HOURS / $  WORKED OUT OF DEPT FOR " & Format(Forms![frmPRHistRptDialog]![txtStartDate], "MM/DD") & " - " & Format(Forms![frmPRHistRptDialog]![txtEndDate], "MM/DD/YY")
        .Range(.Cells(1, 5), .Cells(1, lngLastColumn)).Merge
        
         For lngK = 1 To lngDeptCount
           lngCurColumn = (lngK * 3) + 2
           .Cells(2, lngCurColumn).Value = strDept(lngK)
           .Range(.Cells(2, lngCurColumn), .Cells(2, lngCurColumn + 2)).Merge
        Next lngK
        
        .Cells(3, 1).Value = "Pay Rate"
        .Range(.Cells(1, 1), .Cells(3, 1)).Merge
        
        .Cells(3, 2).Value = "Name"
        .Range(.Cells(1, 2), .Cells(3, 2)).Merge
        
        .Cells(3, 3).Value = "Emp ID"
        .Range(.Cells(1, 3), .Cells(3, 3)).Merge
        
        .Cells(3, 4).Value = "Home Dept"
        .Range(.Cells(1, 4), .Cells(3, 4)).Merge
        
          For lngK = 1 To lngDeptCount
            lngCurColumn = (lngK * 3) + 2
            .Cells(3, lngCurColumn).Value = "Hrs"
            .Cells(3, lngCurColumn + 1).Value = "OTP"
            .Cells(3, lngCurColumn + 2).Value = "$"
          Next lngK
        
         .Range(.Cells(1, 1), .Cells(3, lngLastColumn)).Borders.Weight = 3
         .Range(.Cells(1, 1), .Cells(3, lngLastColumn)).Wraptext = True
         .Range(.Cells(1, 1), .Cells(3, lngLastColumn)).Font.Bold = True
         .Range(.Cells(1, 1), .Cells(3, lngLastColumn)).HorizontalAlignment = 3
     End With
    
      Return


End Function

Open in new window

0
 

Author Comment

by:gordonwwaugh
ID: 34919576
Very cool. So, the code loops through the records in the query's recordset. And it writes the values directly into the Excel spreadsheet.
0
 
LVL 57
ID: 34920246
<<Very cool. So, the code loops through the records in the query's recordset. And it writes the values directly into the Excel spreadsheet. >>

  Right.  The idea and general technique is that you open the spreadsheet in code via Automation

  At that point, you can do anything including opening multiple recordsets to fetch the required data, so your not limited to any of the built-in limitiations that exist with something like DoCmd.Transfer

  You push the data into the spreadsheet, format it as required, then close it.

  The code route gives you a lot more control and options over any of the built-in functions.

  Ditto for dealing with ASCII files as well, although that's not quite as complex because VBA has built-in open and read/write statements for file I/O, so your not firing up another application via automation.  But again, you can pretty much do anything you want with the file once it's open.

JimD.
0
 

Author Comment

by:gordonwwaugh
ID: 34920387
Thanks very much. I have dabbled in using VBA to read/write using ASCII files.
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Suggested Solutions

When you are entering numbers in a speadsheet, and don't remember what 6×7 is, you just type “=6*7" instead. It works in every cell! This is not so in Access. To enter the elusive 42 in a text box, you have to find a calculator, and then copy the re…
Overview: This article:       (a) explains one principle method to cross-reference invoice items in Quickbooks®       (b) explores the reasons one might need to cross-reference invoice items       (c) provides a sample process for creating a M…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…

757 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

17 Experts available now in Live!

Get 1:1 Help Now