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.
If i then select Debug from the pop up it leads me to the following part of the code highlighting it in yellow.
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:
------------------------------------------
This part of code is located in a Module:
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.
If i then select Debug from the pop up it leads me to the following part of the code highlighting it in yellow.
Code:
Set NewMenu = CommandBars(1).Controls.Add _
(Type:=msoControlPopup, _
Before:=HelpMenu.Index, _
temporary:=True)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:
Code:
Private Sub Workbook_Open()
Call CreateMenu
End Sub------------------------------------------
This part of code is located in a Module:
Code:
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
