Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations danielledunham on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Pivot table code when creating excel interface

Status
Not open for further replies.

dandot

Programmer
Joined
Jul 19, 2005
Messages
53
Location
CA
Hi All,

I have an access module that creates an excel spreadsheet. I would like to create a pivot table on tab 2 of the spreadsheet. Any ideas? the code is below.

Thanks!

Public Sub New_MakeExcel_Interface(ByVal strQuery As String, ByVal strFilter As String, ByVal sWSheetName As String, ByVal btranspose As Boolean)
' Updates an Excel worksheet using Automation.
' Input parameters:
' strSQL = SQL to extract data for Excel or name of the query
' strFilter = Filter
' sWSheetName = name of the worksheet
' btranspose = Yes ==> Field names in first column; False ==> Field names in first row
Dim rst As New ADODB.Recordset
Dim recArray As Variant
Dim fldCount As Integer
Dim recCount As Long
Dim iCol, i As Integer
Dim iRow As Integer
Dim vSize As Variant
Dim bMemo As Boolean
Dim strMemoValue As String

On Error GoTo HandleErr

bMemo = False
DoCmd.Hourglass True
' Open recordset based on extraction query
rst.Open strQuery, CurrentProject.Connection
rst.Filter = strFilter
fldCount = rst.Fields.Count
If (rst.EOF And rst.BOF) Then
MsgBox "Sorry, no data found for this query", vbExclamation
GoTo ExitHere
End If

' Create an instance of Excel and add a workbook
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets("Sheet1")
xlApp.UserControl = True 'Give user control of Excel's lifetime

xlWs.Cells.Select
With xlApp.Selection 'General spreadsheet formatting
' .HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
End With
If sWSheetName = "OPC Control Counts in ICR" Then
xlApp.Rows("1:1").Select
xlApp.Selection.HorizontalAlignment = xlCenter
xlApp.Selection.VerticalAlignment = xlBottom
xlApp.Selection.WrapText = True
xlApp.Selection.RowHeight = 100
End If
xlWs.Cells(2, 1).CopyFromRecordset rst

For iCol = 1 To fldCount
xlWs.Cells(1, iCol).Value = rst.Fields(iCol - 1).Name
xlWs.Cells(1, iCol).Font.Bold = True
xlWs.Cells(1, iCol).Font.size = 10
xlWs.Cells(1, iCol).Interior.ColorIndex = 15
xlWs.Cells(1, iCol).Interior.Pattern = xlSolid
If sWSheetName = "OPC Control Counts in ICR" Then
' Only for Report 01
If iCol > 2 Then
xlWs.Cells(1, iCol).Orientation = 90
End If
End If
If rst.Fields(iCol - 1).DefinedSize > 50 Then
' For all the text/memo fields of length > 50
xlWs.Columns(iCol).Select
xlApp.Selection.ColumnWidth = 75 '50
xlApp.Selection.WrapText = True
End If
If rst.Fields(iCol - 1).Type = adDate Then
' For all the date fields of length > 100
xlWs.Columns(iCol).Select
xlApp.Selection.NumberFormat = "m/dd/yyyy"
End If
bMemo = bMemo Or (rst.Fields(iCol - 1).DefinedSize > 500)

Next

If bMemo Then
' Re-paste Memo fields
iRow = 2
rst.MoveFirst
Do While Not rst.EOF
For iCol = 1 To fldCount
If (rst.Fields(iCol - 1).DefinedSize > 500) And _
(Len(rst(iCol - 1)) > 1) _
Then
'xlWs.Cells(iRow, iCol).Value = rst(iCol - 1) & ""
strMemoValue = rst(iCol - 1) & ""
' Debug.Print strMemoValue
' Debug.Print Len(strMemoValue)
If Len(strMemoValue) > 1024 Then
For i = 2 To Len(strMemoValue) Step 50
strMemoValue = Left(strMemoValue, i - 1) & Replace(strMemoValue, ". ", "." & Chr(10), i, 1)
Next i
' Debug.Print strMemoValue
End If
xlWs.Cells(iRow, iCol).Value = strMemoValue
End If
Next
iRow = iRow + 1
rst.MoveNext
Loop
End If

DoCmd.SetWarnings False
xlApp.DisplayAlerts = False
' Transpose
If btranspose Then
With xlApp
.Range("A1").Select
.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
.Selection.Copy
.Sheets.Add
.Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End With
xlWb.Worksheets("Sheet1").Delete
End If
' Rename the worksheet
If Len(sWSheetName) < 1 Then
sWSheetName = "Process"
End If
If btranspose Then
xlWb.Worksheets("Sheet4").Name = sWSheetName
Else
xlWb.Worksheets("Sheet1").Name = sWSheetName
End If
xlWb.Worksheets("Sheet2").Delete
xlWb.Worksheets("Sheet3").Delete
xlApp.DisplayAlerts = True
DoCmd.SetWarnings True
' Auto-fit the column widths and row heights
xlApp.Selection.CurrentRegion.Columns.AutoFit
xlApp.Selection.CurrentRegion.Rows.AutoFit
' Now display Excel
xlApp.Range("A1").Select
xlApp.Visible = True

ProcDone:
On Error Resume Next
' Clean up
Set xlWs = Nothing
Set xlWb = Nothing
Set xlApp = Nothing

ExitHere:
' Close ADO objects
rst.Close
Set rst = Nothing
DoCmd.Hourglass False
Exit Sub

HandleErr:
MsgBox "In New_MakeExcel_Interface: " & Err & ": " & Err.Description

Resume ExitHere

End Sub
 


I'd open Excel, turn on the macro recorder, and record creating a pivot table.

Skip,

[glasses] [red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![tongue]
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top