none
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

     

     

     

    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 Sub


     

     

    Friday, March 28, 2008 5:47 PM