Thanks Simon....
I've moved a step forward with the Excel output now showing part of my pivot table graph. However, one of the pivot table fields is missing and the error has now changed to
"Error 1004 : Method 'Cells of Object'_Global' failed.
Any idea what may be wrong now?
Here's the Macro that I'm trying to run (MacroX at the bottom being the problem):
' Excel Macro to prepare Tab-separated file ReportData.txt for printing
' written by David Stott
'
' Parameters are read from first line of report
' New parameters must be added to function GetParameters
' for Strings use readValue, for Booleans use readToken
Dim ReportTitle As String 'Title eg My Report
Dim RepeatCols As String 'FCols eg 1,2,3
Dim HorizBars As String 'HBars eg 5
Dim ShowPreview As Boolean 'Preview
Dim Landscape As Boolean 'Landscape
Dim DisplayCount As String 'DisplayCount
Dim SplitCol As String 'SplitCol eg 7,8
Dim RowCount As Integer
Dim ColCount As Integer
Function GetParameters()
Range("1:1").Select
Dim data As String
Do While ActiveCell.value <> ""
data = ActiveCell.value
ReportTitle = readValue(data, "Title", ReportTitle)
HorizBars = readValue(data, "HBars", HorizBars)
ShowPreview = readToken(data, "Preview", ShowPreview)
Landscape = readToken(data, "Landscape", Landscape)
RepeatCols = readValue(data, "FCols", RepeatCols)
SplitCol = readValue(data, "SplitCol", SplitCol)
DisplayCount = readValue(data, "DisplayCount", DisplayCount)
ActiveCell.Offset(0, 1).Select
Loop
RepeatCols = ConvertCol(RepeatCols)
SplitCol = ConvertCol(SplitCol)
End Function
' Main subroutine of Macro starts here ***********************
Sub Auto_Open()
On Error GoTo ErrorHandler
Application.Visible = False
ThePath = ThisWorkbook.Path
Workbooks.Open FileName:=ThePath + "\ReportData.txt"
' Copy the workbook, and close the source file (having marked it as saved)
Set Wbook = ActiveWorkbook
ActiveSheet.Copy
Wbook.Saved = True
Wbook.Close
Set ReportSheet = ActiveSheet
' Set Default parameters
RepeatCols = ""
SplitCol = ""
ReportTitle = ""
HorizBars = "5"
ShowPreview = False
Landscape = False
' Read parameters from first line of report
GetParameters
' Delete first line now that its work is done
Rows("1:1").Select
Selection.Delete Shift:=xlUp
' Calculate number of rows in report
RowCount = Range("A1").SpecialCells(xlCellTypeLastCell).Row
'if not split sheets then take the Column title into account
If SplitCol = "" Then RowCount = RowCount - 1
ColCount = Range("A1").SpecialCells(xlCellTypeLastCell).column
'Rule the columns
RuledColumns
' Delete top line now that its work is done
Rows("1:1").Select
Selection.Delete Shift:=xlUp
' Page Settings
With ReportSheet.PageSetup
.LeftFooter = "Page &P of &N"
.RightFooter = "&D &T"
.CenterHeader = "&14 " + ReportTitle
.PrintTitleRows = "$1:$1"
If RepeatCols >= "A" Then .PrintTitleColumns = "$A:$" + RepeatCols
If Landscape Then .Orientation = xlLandscape Else .Orientation = xlPortrait
If DisplayCount <> "" Then .RightHeader = DisplayCount + " " + Str(RowCount - 2)
End With
' Excel doesn't autofit address block properly so do a hack
FixAddressColumn
MacroX
' Set Automatic column widths
Cells.Select
Selection.HorizontalAlignment = xlLeft
Selection.VerticalAlignment = xlTop
Selection.Columns.AutoFit
' Embolden top line of report (column headings)
Rows("1:1").Select
Selection.Font.bold = True
' Add Grid Lines (Horizontal lines are added in "MakeSheets" if separate lists are requested)
If RepeatCols >= "A" Then VerticalLine (RepeatCols)
If SplitCol = "" Then HorizontalBars first:=1, cycle:=Val(HorizBars), last:=RowCount
Range("A1").Select
' Split list up if required
If SplitCol > "" Then MakeSheets col:=SplitCol
' Display Preview
Application.Visible = True
' Mark the active workbook as saved
ActiveWorkbook.Saved = True
If ShowPreview Then ActiveWindow.SelectedSheets.PrintPreview
'close this workbook
ThisWorkbook.Close
Exit Sub
' Error-handling routine
ErrorHandler:
Application.Visible = True
MsgBox "Error " & Err.Number & " : " & Err.Description
End Sub
Function readValue(data, name, store)
namelen = Len(name) + 1
If UCase(Left(data, namelen)) = UCase(name) + "=" Then store = Right(data, Len(data) - namelen)
readValue = store
End Function
Function readToken(data, name, store)
If UCase(data) = UCase(name) Then store = True
readToken = store
End Function
Sub HorizontalBars(first, cycle, last)
x = first
Do While x < last
HorizontalLine (x)
If cycle <= 0 Then x = last Else x = x + cycle
Loop
End Sub
Sub VerticalLine(Idx)
Columns(Idx + ":" + Idx).Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.weight = xlMedium
End With
End Sub
Function RuledColumns()
Range("1:1").Select
Dim data As String
Do While ActiveCell.value <> ""
data = ActiveCell.value
If Left(data, 1) = "*" Then
ActiveCell.EntireColumn.Select
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.weight = xlThin
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.weight = xlThin
End With
End If
ActiveCell.Offset(0, 1).Select
Loop
End Function
Function FixAddressColumn()
Range("1:1").Select
Do While ActiveCell.value <> ""
If Left(ActiveCell.value, 7) = "Address" Then
ActiveCell.EntireColumn.ColumnWidth = 50
End If
ActiveCell.Offset(0, 1).Select
Loop
End Function
Sub HorizontalLine(Idx)
i = Trim(Str(Idx))
Rows(i + ":" + i).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.weight = xlThin
End With
End Sub
Function ConvertCol(Idx)
If Idx = "" Then ConvertCol = "" Else ConvertCol = Chr(Idx + 64)
End Function
Sub MakeSheets(col)
Range(col + "1:" + col + "1").Select
caption = ActiveCell.value
ActiveCell.Offset(1, 0).Select
Dim data As String
frow = 0
value = ""
For r = 2 To RowCount
data = ActiveCell.value
If data <> value And frow <> 0 Then
If value <> "" Then
MakeSheet first:=frow, last:=r - 1, caption:=caption, descr:=value, col:=col
End If
frow = 0
End If
If frow = 0 Then
frow = r
value = data
End If
ActiveCell.Offset(1, 0).Select
Next r
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Sheets.Select
End Sub
Sub MakeSheet(first, last, caption, descr, col)
Sheets("ReportData").Copy After:=Sheets(Sheets.Count)
SetSheetName (descr)
Chop first:=last + 1, last:=RowCount
Chop first:=2, last:=first - 1
With ActiveSheet.PageSetup
.CenterHeader = .CenterHeader + Chr(13) + caption + ": " + descr
If DisplayCount <> "" Then .RightHeader = DisplayCount + " " + Str(last - first + 1)
End With
HorizontalBars first:=1, cycle:=Val(HorizBars), last:=last - first + 3
Range(col + ":" + col).Select
Selection.Delete Shift:=xlRight
fstr = Trim(Str(last - first + 3))
lstr = Trim(Str(RowCount))
Rows(fstr + ":" + lstr).Select
Selection.Style = "Normal"
Columns(col + ":" + ConvertCol(ColCount)).Select
Selection.Style = "Normal"
Range("A1").Select
Sheets("ReportData").Select
End Sub
Sub SetSheetName(value)
For x = 1 To Len(value)
If InStr("[]?/\'", Mid(value, x, 1)) > 0 Then value = Left(value, x - 1) + "." + Mid(value, x + 1)
Next x
On Error Resume Next
ActiveSheet.name = value
End Sub
Sub Chop(first, last)
If last >= first Then
fstr = Trim(Str(first))
lstr = Trim(Str(last))
Rows(fstr + ":" + lstr).Delete
End If
End Sub
Sub MacroX()
'
' MacroX Macro
' Macro recorded 30/11/2009 by .
'
'
Cells.Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"ReportData!A1:F220").CreatePivotTable TableDestination:="", TableName:= _
"PivotTable1", DefaultVersion:=xlPivotTableVersion10
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)
ActiveSheet.Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Provision type")
.Orientation = xlColumnField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Provision type"), "Count of Provision type", _
xlCount
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Surname")
.Orientation = xlRowField
.Position = 1
End With
Charts.Add
ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("A3")
ActiveChart.Location Where:=xlLocationAsNewSheet
End Sub
