Asked by:
Pivot Table Create Macro

Question
-
Hi, I'm using Excel 2003 (SP2).
I've created a macro that runs upon workbook open. The workbook contains approximately 11 tabs. The macro code is below. It basically does the following...
1) Checks for the existence of another workbook (rmdbacctindrevrawdata.xls output from Crystal Reports).
2) If the rmdbacctindrevrawdata.xls exists open it and repopulate the raw data tab (1 of the 11 tabs).
3) Populate the remaining 10 tabs from the raw data tab.
4) Open a second workbook (workbook the end user will use) and copy the 10 refreshed tabs into the new workbook.
5) On an empty sheet in the user workbook create two pivot tables from one of the 10 tabs.
Everything works fine - even creating the two pivot tables. The problem occurs after I copy the first pivot table to create the second pivot table. When I attempt to set the RowFields in the second pivot table I get the following message:
Run-time error '438': Object doesn't support this property or method.
The code line below that causes this error is just after the line "'**************** THIS LINE GIVES THE ERROR ****************".
About 10 lines from the bottom. I'm not sure why this is a problem as about 11 lines above this I use the same code to set the RowFields in the first pivot table.
I attempted to change AddFields to UpdateFields or UpdFields but I haven't had any luck. I'm very unfamiliar with the VBA Object Model and I'm surprised I've gotten as far as I have so quickly but I'm pretty stuck on this. Anyone have any suggestions?
Thanks
Code SnippetPrivate Sub Workbook_Open()
' Check and see if a Crystal Report Excel output file rmdbacctindrevrawdata.xls exists.
' If a file doesn't exist exit and don't repopulate this workbook.
Dim sPath As String
sPath = "C:\Documents and Settings\MS130628\My Documents\Teradata Marketing\Projects\Reports\Duns Revenue\Dougs Files Duns Load\ExcelLoading\Live\rmdbacctindrevrawdata.xls"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
' Test if directory or file exists
If fso.FileExists(sPath) Then
PopWrkBook
Else
Application.DisplayAlerts = False
Set fso = Nothing
Application.Quit
End If
Sheets("RawData").Cells.ClearContents
Sheets("RawData").Visible = False
Application.DisplayAlerts = False
Set fso = Nothing
Application.Quit
End Sub' Main procedure that is executed to populate this workbook. Only executed if a
' Crystal Reports Excel output file exists.
Sub PopWrkBook()
' Declare and populate an array with all worksheet names that need to be repopulated.
Dim aIndWrkShtArr(13)
aIndWrkShtArr(1) = "Finance"
aIndWrkShtArr(2) = "Comm-Media"
aIndWrkShtArr(3) = "Gov"
aIndWrkShtArr(4) = "Healthcare"
aIndWrkShtArr(5) = "Insurance"
aIndWrkShtArr(6) = "Mfg"
aIndWrkShtArr(7) = "Retail"
aIndWrkShtArr(8) = "Transportation"
aIndWrkShtArr(9) = "Travel"
aIndWrkShtArr(10) = "Non-Targeted"
aIndWrkShtArr(11) = "OtherIndustries"
aIndWrkShtArr(12) = "Partners+Influencers"
aIndWrkShtArr(13) = "AllIndustries"' Unhide raw data sheet and make sure it's empty. Open new data workbook from Crystal Reports.
' Copy in new workbook data. Close new workbook.
Sheets("RawData").Visible = True
Sheets("RawData").Select
Cells.ClearContents
Workbooks.Open Filename:= _
"C:\Documents and Settings\MS130628\My Documents\Teradata Marketing\Projects\Reports\Duns Revenue\Dougs Files Duns Load\ExcelLoading\Live\rmdbacctindrevrawdata.xls"
Cells.Copy
Windows("rmdbacctindrevmacro.xls").Activate
ActiveSheet.Paste
Application.CutCopyMode = False' This macro was originally in procedure called "Auto_Open". It was changed to be in a procedure called
' "Workbook_Open". Macro wasn't automatically running via "Auto_Open". After the change was made the
' following line of code stopped working. Didn't matter that the source data workbook was closed as it
' disappears when Excel closes so the line was just commented out.
' Windows("rmdbacctindrevrawdata.xls").Close' Call a procedure that will delete all data from the worksheets.
EmptyWorksheets (aIndWrkShtArr)' Sort data in raw data sheet by industry - in preparation for populating individual industry sheets.
Sheets("RawData").Select
Cells.Sort Key1:=Range("F1"), Order1:=xlAscending, Key2:=Range("A1"), Order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal' Loop through the array of sheets and determine which RMDB industry name
' each sheet maps to. Then call a procedure that will populate each sheet.
Dim sWrkShtName As String
For i = 1 To UBound(aIndWrkShtArr)
Select Case aIndWrkShtArr(i)
Case "AllIndustries"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "AllIndustries"
Case "Finance"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Financial"
Case "Comm-Media"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Comm & Media/Ent"
Case "Gov"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Government"
Case "Healthcare"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Healthcare"
Case "Insurance"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Insurance"
Case "Mfg"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Manuf"
Case "Retail"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Retail"
Case "Transportation"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Transportation"
Case "Travel"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Travel"
Case "Non-Targeted"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Non-Target"
Case "OtherIndustries"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Other Industries"
Case "Partners+Influencers"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Partners+Influencers"
End Select
Next i' Call a procedure that will sort format the data in all worksheets.
FormatWrkSheets (aIndWrkShtArr)
' Call a procedure that will create a blank workbook and copy all data sheets in this workbook
' into the new workbook. This new workbook is the workbook users will download without this macro.
CreateUserWrkBook (aIndWrkShtArr)
' Make sure clipboard is empty before ending.
Application.CutCopyMode = False
Set fso = Nothing
End Sub' Procedure takes in an array of sheet names and removes all data from each sheet. And activate
' cell A1 in each sheet in preperation for pasting in new industry specific data.
Sub EmptyWorksheets(IndWrkShtArr As Variant)
For i = 1 To UBound(IndWrkShtArr)
With Sheets(IndWrkShtArr(i))
.Cells.ClearContents
Sheets("RawData").Range("1:1").Copy Destination:=.Range("A1")
End With
Next i
End Sub' Procedure is passed an industry worksheet name and a corresponding RMDB industry name. The
' procedure determines the start and row of the industry data in the raw worksheet, copies those
' rows into the appropriate industry worksheet.
Sub PopWorkSheets(sWrkShtName As String, sIndName As String)
Dim iRowStartNo As Integer
Dim iRowLastNo As Integer
' If the All Industries worksheet is being worked copy in all industry data otherwise just
' copy in industry specific data.
If sWrkShtName = "AllIndustries" Then
Cells.Copy Destination:=Sheets(sWrkShtName).Range("A1")
Sheets("RawData").Select
Else
' Call functions to determine start and end rows. Then select and copy rows into target
' industry worksheeet. Put focus back on cell A1 in raw data worksheet (prep for next
' pass through).
iRowStartNo = IndStartRowNo(sIndName)
iRowLastNo = IndLastRowNo(sIndName)
' If the start or last row values = 1 the functions that looked for start and loast rows
' didn't find any data for the industry being processed. Skip around the copying and pasting
' in this situation and leave an empty tab.
If (iRowStartNo <> 1 And iRowLastNo <> 1) Then
Range("A" & iRowStartNo, "N" & iRowLastNo).Copy Destination:=Sheets(sWrkShtName).Range("A2")
Sheets("RawData").Select
Range("A1").Select
End If
End If
End Sub' Function returns the row # of the first row that contains the specified
' industry in the industry column of the raw data sheet.
Function IndStartRowNo(sIndustry As String) As Integer
Columns("F:F").Select
' The following find will throw an error if an industry that is being processed is not
' found in the RawData tab. Avoid the error and continue processing. Any industry that
' caused an error will end up with an empty tab of data.
On Error Resume Next
Selection.Find(What:=sIndustry, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
IndStartRowNo = ActiveCell.Row
End Function' Function returns the row # of the last row that contains the specified
' industry in the industry column of the raw data sheet.
Function IndLastRowNo(sIndustry As String) As Integer
Columns("F:F").Select
' The following find will throw an error if an industry that is being processed is not
' found in the RawData tab. Avoid the error and continue processing. Any industry that
' caused an error will end up with an empty tab of data.
On Error Resume Next
Selection.Find(What:=sIndustry, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:= _
False, SearchFormat:=False).Activate
IndLastRowNo = ActiveCell.Row
End Function' Procedure takes in an array of worksheet names and sort by revenue, then account name and formats
' each. Also hide the revenue year, account no, duns no and internal publicity clause columns.
Sub FormatWrkSheets(IndWrkShtArr As Variant)
For i = 1 To UBound(IndWrkShtArr)
Sheets(IndWrkShtArr(i)).Select
If IndWrkShtArr(i) = "AllIndustries" Then
Cells.Sort Key1:=Range("A1"), Order1:=xlDescending, Key2:=Range("E1"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Rows("1:1").Font.Bold = True
Rows("1:1").EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 34.29
Columns("I:I").ColumnWidth = 17.29
Columns("J:J").ColumnWidth = 18.71
Columns("K:K").ColumnWidth = 10.57
Columns("B:B").EntireColumn.Hidden = True
Columns("D:D").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("L:L").EntireColumn.Hidden = True
Columns("M:M").EntireColumn.Hidden = True
ActiveWindow.FreezePanes = True
Range("A1").Select
Else
Rows("1:1").Font.Bold = True
Rows("1:1").EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 34.29
Columns("I:I").ColumnWidth = 17.29
Columns("J:J").ColumnWidth = 18.71
Columns("K:K").ColumnWidth = 10.57
Columns("B:B").EntireColumn.Hidden = True
Columns("D:D").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("L:L").EntireColumn.Hidden = True
Columns("M:M").EntireColumn.Hidden = True
ActiveWindow.FreezePanes = True
Range("A1").Select
End If
Next i
End Sub' Procedure takes in an array of worksheets. Creates a new workbook, Saves the workbook, copies worksheets
' from this workbook into it. Deletes blank sheets in new workbook. Resaves new workbook after population.
' Note: The new workbook must be saved prior to copying worksheets into it. And the sheet copying must be
' done the way its done in order to have them ordered correctly in the new workbook.Sub CreateUserWrkBook(IndWrkShtArr As Variant)
Dim WkBk As Workbook
Set WkBk = Workbooks.Add
Application.DisplayAlerts = False
WkBk.SaveAs Filename:="C:\Documents and Settings\MS130628\My Documents\Teradata Marketing\Projects\Reports\Duns Revenue\Dougs Files Duns Load\ExcelLoading\Live\rmdbacctindrev.xls"
For i = UBound(IndWrkShtArr) To 1 Step -1
If (IndWrkShtArr(i)) <> "AllIndustries" Then
Sheets(IndWrkShtArr(i)).Copy Before:=Workbooks("rmdbacctindrev.xls").Sheets(1)
End If
Next i
Sheets("AllIndustries").Copy Before:=Workbooks("rmdbacctindrev.xls").Sheets("Finance")
Workbooks("rmdbacctindrev.xls").Sheets("Sheet2").Delete
Workbooks("rmdbacctindrev.xls").Sheets("Sheet3").Delete
Workbooks("rmdbacctindrev.xls").Sheets("Sheet1").Move Before:=Workbooks("rmdbacctindrev.xls").Sheets(1)
Workbooks("rmdbacctindrev.xls").Sheets("Sheet1").Name = "PivotSummary"
Workbooks("rmdbacctindrev.xls").Activate
ActiveWindow.TabRatio = 0.9
' *************** BUILD PIVOT CODE *****************
Workbooks("rmdbacctindrev.xls").Activate
Dim iLastRow As Integer
Dim iFirstRow As Integer
Worksheets("AllIndustries").Activate
ActiveCell.SpecialCells(xlLastCell).Select
iLastRow = ActiveCell.Row
iFirstRow = 1
MsgBox (iLastRow & iFirstRow)
Workbooks("rmdbacctindrev.xls").Activate
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Activate
Workbooks("rmdbacctindrev.xls").PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"AllIndustries!R1C1:R" & iLastRow & "C14").CreatePivotTable TableDestination:="", _
TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10
Workbooks("rmdbacctindrev.xls").PivotTableWizard _
TableDestination:=Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Cells(3, 1)
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("A3").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").PivotTables("PivotTable1").AddFields RowFields:=Array( _
"Official Customer", "Industry"), ColumnFields:="Tier"
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").PivotTables("PivotTable1").PivotFields("Account").Orientation = _
xlDataField
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Application.CommandBars("PivotTable").Visible = False
ActiveWorkbook.ShowPivotTableFieldList = False
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("A2:G31").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("G31").Activate
Selection.Copy
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("I2").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Paste
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("L7").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Application.CutCopyMode = False
'**************** THIS LINE GIVES THE ERROR ****************
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary"). _
ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:=Array( _
"Official Customer", "Region"), ColumnFields:="Tier"
' ActiveSheet.PivotTables("PivotTable2").AddFields RowFields:=Array( _
' "Official Customer", "Region"), ColumnFields:="Tier"ActiveWorkbook.ShowPivotTableFieldList = True
Application.CommandBars("PivotTable").Visible = False
ActiveWorkbook.ShowPivotTableFieldList = False
Workbooks("rmdbacctindrevmacro.xls").Activate
WkBk.SaveAs Filename:="C:\Documents and Settings\MS130628\My Documents\Teradata Marketing\Projects\Reports\Duns Revenue\Dougs Files Duns Load\ExcelLoading\Live\rmdbacctindrev.xls"End Sub
Friday, March 21, 2008 1:46 PM
All replies
-
When you copy and paste the pivot table you cannot control the name of the copy. It will not always be "PivotTable2".
Rather than copy and paste, you could create the second table from scratch the same way you created the first one.
Saturday, March 22, 2008 4:08 AM -
Can't believe I didn't think of that. I only code periodically now (losing the edge). Thank for the idea! I will post back about the result.
Monday, March 24, 2008 1:14 AM -
As and FYI the code at the bottom between the asterisk lines is what I was able to use to create the second pivot table.
Thanks for the help.
Code Snippet'****************************************************************************
' Date : 2/26/08
' File : rmdbacctindrevmacro.xls
' Description : This workbook works in conjunction with the Crytal Report (CR)
' rmdbacctindrevrawdata.rpt. That CR outputs a workbook called
' rmdbacctindrevrawdata.xls file. This workbook with an auto_run
' macro reads in the data from the CR workbook and places it into
' this workbooks hidden RawData tab. The data in this tab is then
' split out and placed into industry specific tabs. Then a new
' workbook is created called rmdbacctindrev.xls which is the end
' user workbook. Must create this to provide the end users with
' a workbook that doesn't have a macro in it. The end user workbook
' gets all tabs copied into it except the raw data tab. Then this
' workbook has two pivot tables built in it. Finally, the new end
' user workbook is saved. This macro ends and Excel is shutdown.
' Some notes about this macro:
' 1) It relies on a standard file name from Crystal Reports.
' 2) It relies on hard coded file paths.
' 3) It relies on hard coded industry tab names and hard coded
' industry names (that match the industry names in the RMDB data).
' 4) It relies on RMDB industry names not changing.
'****************************************************************************' Check and see if a Crystal Report Excel output file rmdbacctindrevrawdata.xls exists.
' If a file doesn't exist exit and don't repopulate this workbook.
Dim sPath As String
sPath = "E:\RMDB\Crystal Reports Output\rmdbacctindrevrawdata.xls"
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
' Turn off alerts and test if a Crystal Reports output file exists.
Application.DisplayAlerts = False
If fso.FileExists(sPath) Then
PopWrkBook
Else
Set fso = Nothing
Application.Quit
End If
Sheets("RawData").Cells.ClearContents
Sheets("RawData").Visible = False
Application.DisplayAlerts = False
Set fso = Nothing
Application.Quit
End Sub' Main procedure that is executed to populate this workbook. Only executed if a
' Crystal Reports Excel output file exists.
Sub PopWrkBook()
' Declare and populate an array with all worksheet names that need to be repopulated.
Dim aIndWrkShtArr(13)
aIndWrkShtArr(1) = "Finance"
aIndWrkShtArr(2) = "Comm-Media"
aIndWrkShtArr(3) = "Gov"
aIndWrkShtArr(4) = "Healthcare"
aIndWrkShtArr(5) = "Insurance"
aIndWrkShtArr(6) = "Mfg"
aIndWrkShtArr(7) = "Retail"
aIndWrkShtArr(8) = "Transportation"
aIndWrkShtArr(9) = "Travel"
aIndWrkShtArr(10) = "Non-Targeted"
aIndWrkShtArr(11) = "OtherIndustries"
aIndWrkShtArr(12) = "Partners+Influencers"
aIndWrkShtArr(13) = "AllIndustries"' Unhide RawData sheet then delete it. Open Crystal Reports workbook and copy Sheet1 into macro
' workbook and rename it RawData. Note: We don't just copy in the data due to the Excel
' ActiveCell.SpecialCells(xlLastCell).Select issue.
Sheets("RawData").Delete
Workbooks.Open Filename:= _
"E:\RMDB\Crystal Reports Output\rmdbacctindrevrawdata.xls"
Workbooks("rmdbacctindrevrawdata.xls").Sheets("Sheet1").Copy After:=Sheets("Partners+Influencers")
Sheets("Sheet1").Name = "RawData"
' This macro was originally in procedure called "Auto_Open". It was changed to be in a procedure called
' "Workbook_Open". Macro wasn't automatically running via "Auto_Open". After the change was made the
' following line of code stopped working. Didn't matter that the source data workbook was closed as it
' disappears when Excel closes so the line was just commented out.
' Windows("rmdbacctindrevrawdata.xls").Close' Call a procedure that will delete all data from the worksheets.
EmptyWorksheets (aIndWrkShtArr)' Sort data in raw data sheet by industry - in preparation for populating individual industry sheets.
Sheets("RawData").Select
Cells.Sort Key1:=Range("F1"), Order1:=xlAscending, Key2:=Range("A1"), Order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal' Loop through the array of sheets and determine which RMDB industry name
' each sheet maps to. Then call a procedure that will populate each sheet.
Dim sWrkShtName As String
For i = 1 To UBound(aIndWrkShtArr)
Select Case aIndWrkShtArr(i)
Case "AllIndustries"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "AllIndustries"
Case "Finance"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Financial"
Case "Comm-Media"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Comm & Media/Ent"
Case "Gov"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Government"
Case "Healthcare"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Healthcare"
Case "Insurance"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Insurance"
Case "Mfg"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Manuf"
Case "Retail"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Retail"
Case "Transportation"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Transportation"
Case "Travel"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Travel"
Case "Non-Targeted"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Non-Target"
Case "OtherIndustries"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Other Industries"
Case "Partners+Influencers"
sWrkShtName = aIndWrkShtArr(i)
PopWorkSheets sWrkShtName, "Partners+Influencers"
End Select
Next i' Call a procedure that will sort format the data in all worksheets.
FormatWrkSheets (aIndWrkShtArr)
' Call a procedure that will create a blank workbook and copy all data sheets in this workbook
' into the new workbook. This new workbook is the workbook users will download without this macro.
CreateUserWrkBook (aIndWrkShtArr)
' Make sure clipboard is empty before ending.
Application.CutCopyMode = False
Set fso = Nothing
End Sub' Procedure takes in an array of sheet names and removes all data from each sheet. Also copies
' in header row from the raw data sheet. Note: When AllIndustries sheet is processes this sheet
' is deleted and then recreated. This is done due to the Excel ActiveCell.SpecialCells(xlLastCell).Select
' issue.
Sub EmptyWorksheets(IndWrkShtArr As Variant)
For i = 1 To UBound(IndWrkShtArr)
With Sheets(IndWrkShtArr(i))
If IndWrkShtArr(i) = "AllIndustries" Then
Sheets("AllIndustries").Delete
Worksheets.Add(Before:=Worksheets(1)).Name = "AllIndustries"
Else
.Cells.ClearContents
End If
Sheets("RawData").Range("1:1").Copy Destination:=Sheets(IndWrkShtArr(i)).Range("A1")
End With
Next i
End Sub' Procedure is passed an industry worksheet name and a corresponding RMDB industry name. The
' procedure determines the start and row of the industry data in the raw worksheet, copies those
' rows into the appropriate industry worksheet.
Sub PopWorkSheets(sWrkShtName As String, sIndName As String)
Dim iRowStartNo As Integer
Dim iRowLastNo As Integer
' If the All Industries worksheet is being worked copy in all industry data otherwise just
' copy in industry specific data.
If sWrkShtName = "AllIndustries" Then
Cells.Copy Destination:=Sheets(sWrkShtName).Range("A1")
Sheets("RawData").Select
Else
' Call functions to determine start and end rows. Then select and copy rows into target
' industry worksheeet. Put focus back on cell A1 in raw data worksheet (prep for next
' pass through).
iRowStartNo = IndStartRowNo(sIndName)
iRowLastNo = IndLastRowNo(sIndName)
' If the start or last row values = 1 the functions that looked for start and loast rows
' didn't find any data for the industry being processed. Skip around the copying and pasting
' in this situation and leave an empty tab.
If (iRowStartNo <> 1 And iRowLastNo <> 1) Then
Range("A" & iRowStartNo, "N" & iRowLastNo).Copy Destination:=Sheets(sWrkShtName).Range("A2")
Sheets("RawData").Select
Range("A1").Select
End If
End If
End Sub' Function returns the row # of the first row that contains the specified
' industry in the industry column of the raw data sheet.
Function IndStartRowNo(sIndustry As String) As Integer
Columns("F:F").Select
' The following find will throw an error if an industry that is being processed is not
' found in the RawData tab. Avoid the error and continue processing. Any industry that
' caused an error will end up with an empty tab of data.
On Error Resume Next
Selection.Find(What:=sIndustry, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
IndStartRowNo = ActiveCell.Row
End Function' Function returns the row # of the last row that contains the specified
' industry in the industry column of the raw data sheet.
Function IndLastRowNo(sIndustry As String) As Integer
Columns("F:F").Select
' The following find will throw an error if an industry that is being processed is not
' found in the RawData tab. Avoid the error and continue processing. Any industry that
' caused an error will end up with an empty tab of data.
On Error Resume Next
Selection.Find(What:=sIndustry, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:= _
False, SearchFormat:=False).Activate
IndLastRowNo = ActiveCell.Row
End Function' Procedure takes in an array of worksheet names and sort by revenue, then account name and formats
' each. Also hide the revenue year, account no, duns no and internal publicity clause columns.
' Calls a procedure that does common formatting regardless of what sheet is being processed.
Sub FormatWrkSheets(IndWrkShtArr As Variant)
For i = 1 To UBound(IndWrkShtArr)
Sheets(IndWrkShtArr(i)).Select
If IndWrkShtArr(i) = "AllIndustries" Then
Cells.Sort Key1:=Range("A1"), Order1:=xlDescending, Key2:=Range("E1"), Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
CommonFormatting
ActiveWindow.Zoom = 75
Else
CommonFormatting
End If
Next i
End Sub' Procedure performs formatting common to all sheets.
Sub CommonFormatting()
Rows("1:1").Font.Bold = True
Rows("1:1").EntireRow.AutoFit
Cells.EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 34.29
Columns("I:I").ColumnWidth = 17.29
Columns("J:J").ColumnWidth = 18.71
Columns("K:K").ColumnWidth = 10.57
Columns("B:B").EntireColumn.Hidden = True
Columns("D:D").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("L:L").EntireColumn.Hidden = True
Columns("M:M").EntireColumn.Hidden = True
ActiveWindow.FreezePanes = True
Range("A1").Select
End Sub' Procedure takes in an array of worksheets. Creates a new workbook, Saves the workbook, copies worksheets
' from this macro workbook into it. Deletes all but one of the new sheets in new workbook. Builds two
' pivot tables on the non-deleted workbook. Note: The new workbook must be saved prior to copying
' worksheets into it. And the sheet copying must be done the way its done below in order to have them
' ordered correctly in the new workbook.Sub CreateUserWrkBook(IndWrkShtArr As Variant)
' Create new workbook and copy sheets into it.
Dim WkBk As Workbook
Set WkBk = Workbooks.Add
Application.DisplayAlerts = False
WkBk.SaveAs Filename:="E:\RMDB\Crystal Reports Output\rmdbacctindrev.xls"
For i = UBound(IndWrkShtArr) To 1 Step -1
If (IndWrkShtArr(i)) <> "AllIndustries" Then
Sheets(IndWrkShtArr(i)).Copy Before:=Workbooks("rmdbacctindrev.xls").Sheets(1)
End If
Next i
Sheets("AllIndustries").Copy Before:=Workbooks("rmdbacctindrev.xls").Sheets("Finance")
' Prepare new workbook for pivot table build. Delete sheets created by default. Rename one to hold
' pivot tables. Resize scroll bar.
Workbooks("rmdbacctindrev.xls").Sheets("Sheet2").Delete
Workbooks("rmdbacctindrev.xls").Sheets("Sheet3").Delete
Workbooks("rmdbacctindrev.xls").Sheets("Sheet1").Move Before:=Workbooks("rmdbacctindrev.xls").Sheets(1)
Workbooks("rmdbacctindrev.xls").Sheets("Sheet1").Name = "PivotSummary"
Workbooks("rmdbacctindrev.xls").Activate
ActiveWindow.TabRatio = 0.9
' Identify source data for pivot tables. Note: Code above that does deleting and recreating of
' sheets have comments that reference an issue with ActiveCell.SpecialCells(xlLastCell).Select.
' Here is where the problem is. The line of code below that attempts to get the last active cell
' in a workbook simulates Ctl-End key sequence. Excel in summary a lot of times considers the last
' active cell to be any cell that was ever used even though there isn't any data in the cell. This
' is not so easy to get around - Microsoft actually provides an Excel add-in to make the line below
' work correctly. The add-in is basically a macro (procedure) that figures this out for you. I
' found some on the web that I attempted to incorporate here but they didn't work and varied from
' Excel version to Excel version. Bottom line it was easier and more reliabel to delete and recreate
' sheets.
Workbooks("rmdbacctindrev.xls").Worksheets("AllIndustries").Activate
Dim iLastRow As Integer
Dim iFirstRow As Integer
ActiveCell.SpecialCells(xlLastCell).Select
iLastRow = ActiveCell.Row
iFirstRow = 1
' Build first pivot table (breakdown of AllIndustries tab data by official customer,
' industry and tier.
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Activate
Workbooks("rmdbacctindrev.xls").PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"AllIndustries!R1C1:R" & iLastRow & "C14").CreatePivotTable TableDestination:="", _
TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10
Workbooks("rmdbacctindrev.xls").PivotTableWizard _
TableDestination:=Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Cells(3, 1)
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("A3").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").PivotTables("PivotTable1") _
.AddFields RowFields:=Array( _
"Official Customer", "Industry"), ColumnFields:="Tier"
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").PivotTables("PivotTable1") _
.PivotFields("Account").Orientation = _
xlDataField
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Application.CommandBars("PivotTable") _
.Visible = False
ActiveWorkbook.ShowPivotTableFieldList = False'************************************************************
'************************************************************
' Build second pivot table (breakdown of AllIndustries tab data by official customer, region and
' tier.
Range("J3").Select
ActiveWorkbook.Worksheets("PivotSummary").PivotTables("PivotTable1").PivotCache _
.CreatePivotTable TableDestination:="[rmdbacctindrev.xls]PivotSummary!R3C9", _
TableName:="PivotTable5", DefaultVersion:=xlPivotTableVersion10
ActiveWorkbook.ShowPivotTableFieldList = True
With ActiveWorkbook.ActiveSheet.PivotTables("PivotTable5").PivotFields("Official Customer")
.Orientation = xlRowField
.Position = 1
End With
With ActiveWorkbook.ActiveSheet.PivotTables("PivotTable5").PivotFields("Region")
.Orientation = xlRowField
.Position = 2
End With
With ActiveWorkbook.ActiveSheet.PivotTables("PivotTable5").PivotFields("Tier")
.Orientation = xlColumnField
.Position = 1
End With
ActiveWorkbook.ActiveSheet.PivotTables("PivotTable5").AddDataField ActiveWorkbook.ActiveSheet.PivotTables( _
"PivotTable5").PivotFields("Account"), "Count of Account", xlCount
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False'************************************************************
'************************************************************
' Final cleanup of pivot table build work (delete temporary tab automatically created by pivot
' pivot table create statement, format columns, make A1 active cell.
Workbooks("rmdbacctindrev.xls").Worksheets("AllIndustries").Activate
Workbooks("rmdbacctindrev.xls").Worksheets("AllIndustries").Range("A2").Select
Workbooks("rmdbacctindrev.xls").Worksheets("AllIndustries").Range("A1").Select
Workbooks("rmdbacctindrev.xls").Sheets("Sheet4").Delete
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Activate
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Range("A1").Select
Workbooks("rmdbacctindrev.xls").Worksheets("PivotSummary").Columns("A:A").ColumnWidth = 16.29
' Save user workbook that was built.
WkBk.SaveAs Filename:="E:\RMDB\Crystal Reports Output\rmdbacctindrev.xls"
End SubFriday, March 28, 2008 5:47 PM