Problem with CreatMenu Code after 12 Months!

[charllie]

Hi Folks,

The following code below was very kindly created for me by someone approx 12 months ago and I have been using it without any problems at all.

The purpose of the code is to creates a new Menu/Title item named "Quality" on the main Excel menu bar at the top of Excel and place it between the "Windows" and "Help"

This new Quality menu then has further drop lists which i can add as suited.

Two days ago i started getting the following RunTime Error everytime i open Excel and i can not longer get the new menu "Quality" to show on my Excel menu bar.

run-time error '2147467259 (80004005)':
Method 'Add' of object 'CommandBarControls' failed

If i then select Debug from the pop up it leads me to the following part of the code highlighting it in yellow.

        Set NewMenu = CommandBars(1).Controls.Add _
                      (Type:=msoControlPopup, _
                       Before:=HelpMenu.Index, _
                       temporary:=True)

I have not made any changes to my version of Excel, nor downloaded any updates or added any new add on's.


I would really appreciate it if someone could help me to find out what has suddenly gone wrong with my code.


Thanks

Charllie


Below is the full code that i am using. There are two sections to the code, a module and ThisWorkbook both in PERSONAL.xls.

This part of code is located in ThisWorkbook:

Private Sub Workbook_Open()
    Call CreateMenu
End Sub

------------------------------------------

This part of code is located in a Module:

Sub CreateMenu()


    Dim NewMenu As CommandBarPopup, sItemName As String, HelpMenu, MenuItem

    '   Delete the menu if it already exists
    Call DeleteMenu

    '   Find the Help Menu
    Set HelpMenu = CommandBars(1).FindControl(ID:=30010)

    If HelpMenu Is Nothing Then
        '       Add the menu to the end
        Set NewMenu = CommandBars(1).Controls.Add _
                      (Type:=msoControlPopup, _
                       temporary:=True)
    Else
        '      Add the menu before Help
        Set NewMenu = CommandBars(1).Controls.Add _
                      (Type:=msoControlPopup, _
                       Before:=HelpMenu.Index, _
                       temporary:=True)
    End If

    '   Add a caption for the menu
    NewMenu.Caption = "Q&uality"

    '   FIRST MENU ITEM - Customer Complaints
    Set MenuItem = NewMenu.Controls.Add _
                   (Type:=msoControlButton)
    With MenuItem
        .Caption = "Daily Report-Customer Complaints"
        .FaceId = 590
        .OnAction = "Transfer1"
    End With

    '   SECOND MENU ITEM - Internal Issues
    Set MenuItem = NewMenu.Controls.Add _
                   (Type:=msoControlButton)
    With MenuItem
        .Caption = "Daily Report-Internal Issues"
        .FaceId = 590
        .OnAction = "Transfer2"
    End With

    '   THIRD MENU ITEM - Customer Query
    Set MenuItem = NewMenu.Controls.Add _
                   (Type:=msoControlButton)
    With MenuItem
        .Caption = "Daily Report-Customer Query"
        .FaceId = 590
        .OnAction = "Transfer3"
    End With

    '   FORTH MENU ITEM - Refresh Working Report
    Set MenuItem = NewMenu.Controls.Add _
                   (Type:=msoControlButton)
    With MenuItem
        .Caption = "Pams Program"
        .FaceId = 590
        .OnAction = "Transfer4"
    End With

End Sub

Sub DeleteMenu()
    On Error Resume Next
    CommandBars(1).Controls("Budgeting").Delete
End Sub

Sub Transfer1()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Sheets(1).Select

    If ActiveSheet.Name = "Customer Complaints" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    If ActiveSheet.Name = "Internal Issues" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    ActiveSheet.Select
    ActiveSheet.Copy After:=Sheets(1)
    ActiveSheet.Select
    ActiveSheet.Name = "Customer Complaints"
    Sheets("Customer Complaints").Select

    Rows("1:1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=17, Criteria1:="Customer Complaint"

    Range("A1:Q1").Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    'Selection.AutoFilter
    Columns("C:C").ColumnWidth = 10.29
    Columns("L:L").ColumnWidth = 15.14
    Columns("L:L").ColumnWidth = 17.29

    Columns("M:M").Delete Shift:=xlToLeft
    Columns("J:J").Delete Shift:=xlToLeft
    Columns("D:D").Delete Shift:=xlToLeft

    Range("A1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With

    Range("A1:Q1000").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ReadingOrder = xlContext
    End With

    With ActiveSheet.PageSetup
        .LeftHeader = "&14AM   PM  Report"
        .CenterHeader = Format(Date, "dddd  dd mmmm yyyy")
        .RightHeader = Format(Time, "hh:mm")
        .LeftFooter = ""
        .CenterFooter = "Customer Complaints"
        .RightFooter = ""
        .CenterHorizontally = True
        .Zoom = False
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With

    Dim Rng As Range
    Dim Cell As Range

    Set Rng = ActiveSheet.Columns("A").Cells
    Set Rng = Rng.SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0

    For Each Cell In Rng.Cells
        With Cell.Resize(1, 14)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End With
    Next Cell

    'ActiveSheet.PrintPreview

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub Transfer2()                                       'Extracts information from a workbook ocated in G:drive

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Sheets(1).Select

    If ActiveSheet.Name = "Customer Complaints" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    If ActiveSheet.Name = "Internal Issues" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    ActiveSheet.Select
    ActiveSheet.Copy After:=Sheets(1)
    ActiveSheet.Select
    ActiveSheet.Name = "Internal Issues"
    Sheets("Internal Issues").Select

    Rows("1:1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=17, Criteria1:="Internal Issue / NCR"

    Range("A1:Q1").Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    'Selection.AutoFilter
    Columns("C:C").ColumnWidth = 10.29
    Columns("L:L").ColumnWidth = 15.14
    Columns("L:L").ColumnWidth = 17.29

    Columns("M:M").Delete Shift:=xlToLeft
    Columns("J:J").Delete Shift:=xlToLeft
    Columns("D:D").Delete Shift:=xlToLeft

    Range("A1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With

    Range("A1:Q1000").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ReadingOrder = xlContext
    End With

    With ActiveSheet.PageSetup
        .LeftHeader = "&14AM   PM  Report"
        .CenterHeader = Format(Date, "dddd  dd mmmm yyyy")
        .RightHeader = Format(Time, "hh:mm")
        .LeftFooter = ""
        .CenterFooter = "Internal Issues"
        .RightFooter = ""
        .CenterHorizontally = True
        .Zoom = False
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With

    Dim Rng As Range
    Dim Cell As Range

    Set Rng = ActiveSheet.Columns("A").Cells
    Set Rng = Rng.SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0

    For Each Cell In Rng.Cells
        With Cell.Resize(1, 14)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End With
    Next Cell

    'ActiveSheet.PrintPreview

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Sub Transfer3()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Sheets(1).Select

    If ActiveSheet.Name = "Customer Complaints" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    If ActiveSheet.Name = "Internal Issues" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If

    If ActiveSheet.Name = "Customer Query" Then
        Call MsgBox("You cannot create a report unless you select the main worksheet" _
                    & vbCrLf & "( Example: 21.06.06 am)" _
                    & vbCrLf & "Please select the correct worksheet and then try again." _
                    , vbCritical, "Please Select The Main Worksheet")
        Sheets(1).Select
        Exit Sub
    End If


    ActiveSheet.Select
    ActiveSheet.Copy After:=Sheets(1)
    ActiveSheet.Select
    ActiveSheet.Name = "Customer Query"
    Sheets("Customer Query").Select

    Rows("1:1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=17, Criteria1:="Customer Query"

    Range("A1:Q1").Select
    With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
    End With
    'Selection.AutoFilter
    Columns("C:C").ColumnWidth = 10.29
    Columns("L:L").ColumnWidth = 15.14
    Columns("L:L").ColumnWidth = 17.29

    Columns("M:M").Delete Shift:=xlToLeft
    Columns("J:J").Delete Shift:=xlToLeft
    Columns("D:D").Delete Shift:=xlToLeft

    Range("A1").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With

    Range("A1:Q1000").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .ReadingOrder = xlContext
    End With

    With ActiveSheet.PageSetup
        .LeftHeader = "&14AM   PM  Report"
        .CenterHeader = Format(Date, "dddd  dd mmmm yyyy")
        .RightHeader = Format(Time, "hh:mm")
        .LeftFooter = ""
        .CenterFooter = "Customer Complaints"
        .RightFooter = ""
        .CenterHorizontally = True
        .Zoom = False
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With

    Dim Rng As Range
    Dim Cell As Range

    Set Rng = ActiveSheet.Columns("A").Cells
    Set Rng = Rng.SpecialCells(xlCellTypeConstants, xlNumbers)
    On Error GoTo 0

    For Each Cell In Rng.Cells
        With Cell.Resize(1, 14)
            With .Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThick
                .ColorIndex = xlAutomatic
            End With
            With .Borders(xlInsideVertical)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        End With
    Next Cell

    'ActiveSheet.PrintPreview

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub Transfer4()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    'Refreshes all the pivot tables
    Sheets("Pivot").Select
    ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable3").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable4").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable5").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable6").PivotCache.Refresh
    ActiveSheet.PivotTables("PivotTable7").PivotCache.Refresh
    Sheets("Summary").Select


    'Saves the Working Report before making any further changes
    '        ActiveWorkbook.save


    'This code performs the save as function and saves it as
    'a new Finished Workbook
    Dim Message, Title, Default, MyValue, MyValue2, MyValue3, MyValue4, MyValue5, MyValue6, WSValue

    'MessageBox for Week Number
    Message = "Pam, ENTER THE WEEK NUMBER and Push the Button If You Dare:" & vbCr & vbCr    ' Set prompt.
    Title = "Add Week Number"
    Default = ""                                      ' Set default.

    ' Display message, title, and default value.

myLoop:
    MyValue = InputBox(Message, Title, Default)

    'Optional: Force an answer!
    If (MyValue = vbNullString Or MyValue = "" Or MyValue = " ") Then
        MsgBox "You must answer this!", vbOKOnly + vbCritical, "Error!"
        GoTo myLoop
    End If


    With Sheets("Summary")
        .Range("AJ2") = MyValue                       'Places the week number in Cell AJ2
    End With

    ActiveWorkbook.SaveAs _
            "G:\Cwmbran-new\Quality\CUSTOMER COMPLAINTS\Customer Complaints 2006\Weekly Reports\Finished Weekly Reports\Complaint Report Week -" _
            & MyValue, Password:="", WriteResPassword:=""



    'This prepares the Summary Sheet ready

    Sheets("Summary").Select

    Dim End_Row As Long

    With Sheets("Summary")
        End_Row = .Range("AI65536").End(xlUp).Row     'Copies and pastes the week figures
        '.Range("A6:AF" & End_Row).Copy
        '.Range("A6:AF" & End_Row).PasteSpecial xlValues

        'If End_Row < 56 Then
        '    .Rows(End_Row + 1 & ":56").EntireRow.Delete    'Deletes the forthcoming weeks
        'End If

        .Rows("59:117").Delete                        'Deletes the outer rows
        '.Columns("AG:AI").Delete                      'Deletes the outer columns

        '=============================================
        'Internal Complaints Input MessageBox
        Message = "Enter Internal Complaints:" & vbCr & vbCr    ' Set prompt.
        Title = "Internal Complaints"
        Default = ""                                  ' Set default.

        ' Display message, title, and default value.

myLoop2:
        MyValue2 = InputBox(Message, Title, Default)

        'Optional: Force an answer!
        If (MyValue2 = vbNullString Or MyValue2 = "" Or MyValue2 = " ") Then
            MsgBox "You Must Enter A Figure For this Even If It Is A Zero!", vbOKOnly + vbCritical, "Error!"
            GoTo myLoop2
        End If

        .Cells(End_Row, 4) = MyValue2
        '--------------------------------------------------

        'Cwmbran Figures Input MessageBox
        Message = "Enter The Number of Orders Raised for CWMBRAN:" & vbCr & vbCr    ' Set prompt.
        Title = "Cwmbran Orders Raised"
        Default = ""                                  ' Set default.

        ' Display message, title, and default value.

myLoop3:
        MyValue3 = InputBox(Message, Title, Default)

        'Optional: Force an answer!
        If (MyValue3 = vbNullString Or MyValue3 = "" Or MyValue3 = " ") Then
            MsgBox "You Must Enter A Figure For this Even If It Is A Zero!", vbOKOnly + vbCritical, "Error!"
            GoTo myLoop3
        End If

        .Cells(End_Row, 16) = MyValue3
        '--------------------------------------------------

        'Poland Figures Input MessageBox
        Message = "Enter The Number of Orders Raised for POLAND:" & vbCr & vbCr    ' Set prompt.
        Title = "Poland Orders Raised"
        Default = ""                                  ' Set default.

        ' Display message, title, and default value.

myLoop4:
        MyValue4 = InputBox(Message, Title, Default)

        'Optional: Force an answer!
        If (MyValue4 = vbNullString Or MyValue4 = "" Or MyValue4 = " ") Then
            MsgBox "You Must Enter A Figure For this Even If It Is A Zero!", vbOKOnly + vbCritical, "Error!"
            GoTo myLoop4
        End If

        .Cells(End_Row, 19) = MyValue4
        '--------------------------------------------------

        'Luxembourg Figures Input MessageBox
        Message = "Enter The Number of Orders Raised for LUXEMBOURG:" & vbCr & vbCr    ' Set prompt.
        Title = "Luxembourg Orders Raised"
        Default = ""                                  ' Set default.

        ' Display message, title, and default value.

myLoop5:
        MyValue5 = InputBox(Message, Title, Default)

        'Optional: Force an answer!
        If (MyValue5 = vbNullString Or MyValue5 = "" Or MyValue5 = " ") Then
            MsgBox "You Must Enter A Figure For this Even If It Is A Zero!", vbOKOnly + vbCritical, "Error!"
            GoTo myLoop5
        End If

        .Cells(End_Row, 22) = MyValue5
        '--------------------------------------------------

        'Australian Figures Input MessageBox
        Message = "Enter The Number of Orders Raised for AUSTRALIA:" & vbCr & vbCr    ' Set prompt.
        Title = "Australian Orders Raised"
        Default = ""                                  ' Set default.

        ' Display message, title, and default value.

myLoop6:
        MyValue6 = InputBox(Message, Title, Default)

        'Optional: Force an answer!
        If (MyValue6 = vbNullString Or MyValue6 = "" Or MyValue6 = " ") Then
            MsgBox "You Must Enter A Figure For this Even If It Is A Zero!", vbOKOnly + vbCritical, "Error!"
            GoTo myLoop6
        End If

        .Cells(End_Row, 25) = MyValue6
        '--------------------------------------------------


        .Range("A6:AF" & End_Row).Copy
        .Range("A6:AF" & End_Row).PasteSpecial xlValues

        If End_Row <= 56 Then
            .Rows(End_Row + 1 & ":56").EntireRow.Delete    'Deletes the forthcoming weeks
        End If
        '=============================================

        '        If End_Row < 56 Then
        '            .Rows(End_Row + 1 & ":56").EntireRow.Delete    'Deletes the forthcoming weeks
        '        End If

                .Rows("59:117").Delete                        'Deletes the outer rows
        '        .Columns("AG:AI").Delete                      'Deletes the outer columns


        ActiveWindow.FreezePanes = False              'Removes the freezepane

    End With

    Sheets("Pivot").Delete                            'Deletes the Pivot Table worksheet
    Sheets("Not Upheld").Delete                       'Deletes the Not Uphelde worksheet


    'This prepares the worksheet "CCs 2006 before copying"
    Sheets("CCs 2006").Select

    With Sheets("CCs 2006")
        Dim x As Long
        Dim y As Range
        Dim Cell As Range
        Set y = ActiveSheet.UsedRange.Rows

        Rows("2:6000").Borders.LineStyle = xlNone     ' Removes all borders

        'This code removes all rows coloured grey
        For x = y.Rows.Count To 1 Step -1
            If y.Rows(x).Cells(1).Interior.ColorIndex = 15 Then
                y.Rows(x).EntireRow.Delete
            End If
        Next x

        'This code adds borders to the cells with info in them and then prints sheet/s
        For Each Cell In Range("A2:A" & Range("A65536").End(xlUp).Row)
            If Not IsEmpty(Cell) Then
                Cell.Resize(1, 19).Borders.LineStyle = xlContinuous
            Else
                Cell.Resize(1, 19).Borders.LineStyle = xlNone
            End If
        Next Cell

        'This changes the font size & style
        Cells.Select
        With Selection.Font
            .Name = "Arial"
            .Size = 10
        End With

        ActiveWindow.FreezePanes = False              'Removes the freezepane
        Selection.AutoFilter                          ' Removes the filters

        Range("A1:S30").Select
        ActiveSheet.PageSetup.PrintArea = "$A$1:$S$30"    'Sets the print area

        Columns("D:D").ColumnWidth = 10.86            'Adjust the size of certain columns
        Columns("E:E").ColumnWidth = 11.57
        Columns("L:L").ColumnWidth = 11.29
    End With



    'Creates new sheets for each Client
    Dim c As Range

    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("PHEI", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            GoTo LineUPI
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "PHEI"

        'autofilter column F to show rows that DO NOT contain "PHEI"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>PHEI"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With


LineUPI:
    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("UPI", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            GoTo LineBVHE
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "UPI"

        'autofilter column F to show rows that DO NOT contain "UPI"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>UPI"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With


LineBVHE:
    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("BVHE", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            GoTo LineMSoft
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "BVHE"

        'autofilter column F to show rows that DO NOT contain "BVHE"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>BVHE"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With


LineMSoft:
    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("M'Soft", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            GoTo LineMGM
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "M'Soft"

        'autofilter column F to show rows that DO NOT contain "M'Soft"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>M'Soft"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With


LineMGM:
    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("MGM", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            GoTo LineOther
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "MGM"

        'autofilter column F to show rows that DO NOT contain "MGM"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>MGM"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With

    '-------------------------------------------------------
    With Sheets("MGM")
        For i = 2 To .Range("a" & .Rows.Count).End(xlUp).Row
            If .Cells(i, "a").MergeCells = True Then .Rows(i).Delete
        Next
        x = .Range("a" & .Rows.Count).End(xlUp).Row
        'Application.CutCopyMode = False
        '.Range("a2:a" & x).Copy .Range("b2")
        'Application.CutCopyMode = True
        .Range("a2:B" & x).Sort Key1:=.Range("B2"), Order1:=xlDescending
        With .Columns("b")
            Set wk = .Find(Range("AJ2").Value, , , xlWhole)
            If Not wk Is Nothing Then
                wk.Offset(1).EntireRow.Insert
                wk.Offset(1, -1).Resize(, 8).MergeCells = True
                wk.Offset(1, -1).Value = "The following are old weeks"
            Else
                Rows(2).Insert
                Range("a2").Resize(, 8).MergeCells = True
                Range("a2").Value = "The following are old weeks"
            End If
        End With
    End With
    '-------------------------------------------------------


LineOther:
    With Sheets("CCs 2006")

        'make sure value exists in column F
        Set c = .Range("F:F").Find("Other", LookIn:=xlValues, lookat:=xlWhole)

        'if value is NOT found
        If c Is Nothing Then
            Exit Sub
        End If

        'if value is found, code continues

        'copy the sheet
        .Copy After:=Sheets(Sheets.Count)
    End With

    With Sheets(Sheets.Count)
        'rename the sheet
        .Name = "Other"

        'autofilter column F to show rows that DO NOT contain "Other"
        .Columns("F:F").AutoFilter Field:=1, Criteria1:="<>Other"

        'delete the rows that are visible
        On Error Resume Next
        .Range("F2:F" & Rows.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0

        'turn off autofilter and display remaining data
        .Range("F1").AutoFilter
    End With


    Sheets("CCs 2006").Delete

    Sheets("Summary").Select
    
    With Sheets("Summary")
        .Columns("AG:AJ").Delete                      'Deletes the outer columns
    End With

    ActiveWorkbook.save

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

 

[Richard Schollar]

Hi Charllie

Try amending that code from:

        Set NewMenu = CommandBars(1).Controls.Add _ 
                      (Type:=msoControlPopup, _ 
                       Before:=HelpMenu.Index, _ 
                       temporary:=True)

to

        Set NewMenu = CommandBars("Worksheet Menu Bar").Controls.Add _ 
                      (Type:=msoControlPopup, _ 
                       Before:=HelpMenu.Index, _ 
                       temporary:=True)

Edit: And if this doesn't work, change HelpMenu.Index to simply Help.Index and try again

 

[charllie]

Hi Richard,

Thanks for your reply, i appreciate your time.

I changed the code as suggested and when i opened Excel i got the same error message:

run-time error '2147467259 (80004005)':
Method 'Add' of object 'CommandBarControls' failed

Then i changed HelpMenu.Index to Help.Index as suggested and tried again.

This time i got the error message:

run-time error '424':
Oject required

The code that got highlighted then was:

        Set NewMenu = CommandBars("Worksheet Menu Bar").Controls.Add _
                      (Type:=msoControlPopup, _
                       Before:=Help.Index, _
                       temporary:=True)

The Quality menu still did not show on the menu bar.

Thanks

 

[Richard Schollar]

I jumped the gun a bit without appreciating what the code was doing. Try this instead:

Set NewMenu = CommandBars("Worksheet Menu Bar").Controls.Add _ 
                      (Type:=msoControlPopup, _ 
                       Before:=CommandBars("Worksheet Menu Bar").Controls("Help").Index, _ 
                       temporary:=True)

I know thi smay sound like a silly question, but you do have the Worksheet Menu Bar visible? This is the one with File, Edit, View, Insert, Format etc etc.

 

[charllie]

Hi Richard,

Thanks again for reply.

I tried using the other code but got the original error message:

run-time error '2147467259 (80004005)':
Method 'Add' of object 'CommandBarControls' failed

Then highlighting your new code.

I know thi smay sound like a silly question, but you do have the Worksheet Menu Bar visible? This is the one with File, Edit, View, Insert, Format etc etc.

Yes the menu bar is visible when i open Excel and after the above dubug has finished. Just to clarify the "Quality" menu always used to show on theis menu bar between "Windows" and "Help".

Thanks

 

[Richard Schollar]

Charllie

There's nothing wrong with your original code (so don't change it) - I think the protection property of the command bar has been altered. Go into the VBE and open up the Immediate Window (Ctrl+G) and paste the following in there (don't miss out the starting '?'):

?commandbars("Worksheet menu bar").Protection

and press return - if it returns the number 1, then it means customization has been disabled. Given that this is the case, type in the following to the Immediate Window and press return (note no '?' this time):

commandbars("Worksheet menu bar").Protection = msoBarNoChangeVisible

This resets it to its defaul;t value. You should then be able to run your macro as before.

Hope this sorts your problem!

 

[charllie]

Hi Richard,

Thanks again for your help.

Tried that and got the number '8' returned.

I still followed your instructions just to try but i am still getting the original error message.

can you think of anything else that may be causing it?

Thanks

 

[Norie]

Charllie

I'm not sure but it sounds to me as though perhaps you've got a corrupt workbook there.

 

[Richard Schollar]

One last thing to try - reset the Worksheet Menu Bar by typing the following into the Immediate Window:

CommandBars("Worksheet menu bar").Reset

and see if that makes a difference. I am afraid I am out of ideas if this doesn't work - you could maybe try a Detect And Repair (via Help menu), but I have no experience of using this so can't really advise if it is likely to work.

 

[charllie]

Hi Richard,

One last thing to try - reset the Worksheet Menu Bar by typing the following into the Immediate Window:

I tried that but still got the same result/error.

I cannot do detect and repair as its a works pc/network and it requires the set up files. Will have to contact the IT department.

I have deleted the code in ThisWorkbook and deleted the Module (i have kept back ups) and now Excel opens up without any errors.

Thanks for all your time and help today, i appreciate it.

Hi Norie,
How are you?

I am not sure if it is a corrupt workbook because it happens everytime i open Excel, even if it is a new workbook or old.

Now i have removed all the cold it all works fine.

Thanks both.