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

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 719
  • Last Modified:

Create Excel spreadsheet with 500 columns from Access crosstab query

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
gordonwwaugh
Asked:
gordonwwaugh
  • 3
  • 2
1 Solution
 
Jim Dettman (Microsoft MVP/ EE MVE)PresidentCommented:

 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
 
Jim Dettman (Microsoft MVP/ EE MVE)PresidentCommented:

 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
 
gordonwwaughAuthor Commented:
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
 
Jim Dettman (Microsoft MVP/ EE MVE)PresidentCommented:
<<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
 
gordonwwaughAuthor Commented:
Thanks very much. I have dabbled in using VBA to read/write using ASCII files.
0

Featured Post

Get your Disaster Recovery as a Service basics

Disaster Recovery as a Service is one go-to solution that revolutionizes DR planning. Implementing DRaaS could be an efficient process, easily accessible to non-DR experts. Learn about monitoring, testing, executing failovers and failbacks to ensure a "healthy" DR environment.

  • 3
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now