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