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 Snippet

Private 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

 

 

 

Answer 1

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.

Answer 2

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.

Answer 3

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 Sub