hi all,
I have a dogs breakfast of a piece of code that you have all helped me write over time and i need some further tweaks. the purpose of the code is to add new outlets to our sales departments Promotional Planner. The planner is split with a Master copy and then several individual account manager copies.
I need to be able to be able to have the Key Account Manager create new outlets in the Master file, and then depending upon the account managers name, go to that file and insert the new outlet sheet. Each file is set up exactly the same with the Outlet sheets between "First" and "Last". Now, I can get the new sheet over into the relevant account managers file, but I can't get the sheets to sort as they do in the master. even tried a before close event in the destination workbook but it wouldn't fire for some reason.
anyway, here is the code so far. I hope its clear enough to follow:
any ideas??
I have a dogs breakfast of a piece of code that you have all helped me write over time and i need some further tweaks. the purpose of the code is to add new outlets to our sales departments Promotional Planner. The planner is split with a Master copy and then several individual account manager copies.
I need to be able to be able to have the Key Account Manager create new outlets in the Master file, and then depending upon the account managers name, go to that file and insert the new outlet sheet. Each file is set up exactly the same with the Outlet sheets between "First" and "Last". Now, I can get the new sheet over into the relevant account managers file, but I can't get the sheets to sort as they do in the master. even tried a before close event in the destination workbook but it wouldn't fire for some reason.
anyway, here is the code so far. I hope its clear enough to follow:
Code:
Private Sub CommandButton1_Click()
Application.Calculation = xlCalculationAutomatic
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
Dim UpdateFileName As Variant
Dim AddSheetQuestion As Variant
Dim pw As Variant
Dim KAM As Variant
Dim LatestSheet As Variant
Dim UpdateKAMsFile As String
Application.ScreenUpdating = False
' Use this code to suppress "sheet deletion" warning
Application.DisplayAlerts = False
'NEED MSG BOX TO ASK IF USER INTENDS TO ADD NEW GROUP
If MsgBox("Do you wish to add a new Outlet Group?", vbYesNo, "NEW OUTLET") = vbNo Then Exit Sub
'input password
pw = InputBox("Enter password:", "Password Required")
If pw <> "password" Then
MsgBox "The password you entered is incorrect"
End
End If
'Define the application input box question
showAddSheetQuestion:
AddSheetQuestion = Application.InputBox("Please Enter New Outlet Group Name:", "Add new Outlet Group")
'Cancel or the X was clicked
If AddSheetQuestion = False Then
MsgBox "You clicked the Cancel button." & vbCrLf & _
"No new sheet will be added.", 64, "Cancel was clicked."
Exit Sub
'OK was clicked without anything being entered
ElseIf AddSheetQuestion = "" Then
MsgBox "You clicked OK but entered nothing." & vbCrLf & vbCrLf & _
"Please type in a valid sheet name." & vbCrLf & _
"Otherwise, you must click Cancel to exit." & vbCrLf & vbCrLf & _
"Click OK and let's try again.", 48, "Hmmm...that didn't make sense..."
GoTo showAddSheetQuestion
End If
'See if a worksheet exists that is named as the new name being attempted to add.
If SheetExists(CStr(AddSheetQuestion)) Then
MsgBox "A worksheet already exists that is named " & AddSheetQuestion & "." _
& vbCrLf & vbCrLf & _
"Please click OK, verify the name you really" & vbCrLf & _
"want to add, and try again." & vbCrLf & vbCrLf & "Sheet addition cancelled.", _
48, "Sorry, that name already taken."
GoTo showAddSheetQuestion
End If
'Here's the actual sheet addition code
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'copy and paste Group Template
Sheets("Group Template").Visible = xlSheetVisible
Sheets("Last").Visible = xlSheetVisible
Worksheets("Group Template").Copy before:=Worksheets("Last")
With ActiveSheet
'force input Outlet Group Name into Proper Case and then remove spaces
.Name = Replace(StrConv(AddSheetQuestion, vbProperCase), " ", "")
.Range("b2").Value = .Range("b2").Value
End With
'identify latest sheet added for later use
LatestSheet = ActiveSheet.Name
'name Key Account Manager
KAM = InputBox("Enter Key Account Manager's Name:", "Name Required")
Application.Goto Reference:="NameAccountManager"
With ActiveCell
.Value = Replace(StrConv(KAM, vbProperCase), " ", " ")
End With
'to re hide it
Sheets("Group Template").Visible = xlVeryHidden
Sheets("Last").Visible = xlVeryHidden
' order Outlet Tabs alphabetically before closing
startt = Sheets("First").Index + 1
endd = Sheets("Last").Index - 1
For i = startt To endd - 1
For j = i + 1 To endd
If Sheets(j).Name < Sheets(i).Name Then
Sheets(j).Move before:=Sheets(i)
End If
Next j
Next i
'add new group to Opportunity Martrix
Worksheets("Opportunity Matrix").Activate
ActiveSheet.Unprotect ("password")
Application.Goto Reference:="NewGroupNameCell"
With ActiveCell
.Value = AddSheetQuestion
.Value = Replace(StrConv(AddSheetQuestion, vbProperCase), " ", "")
End With
Application.Goto Reference:="NewGroupLineFormat"
Selection.Copy
Application.Goto Reference:="NewGroupLine"
Selection.Insert Shift:=xlDown
Application.Goto Reference:=ActiveSheet.UsedRange
ActiveSheet.Protect ("password")
'add new group to Opportunity Martrix2
Worksheets("Opportunity Matrix (2)").Activate
ActiveSheet.Unprotect ("password")
Application.Goto Reference:="NewRangeOutletNameCell"
With ActiveCell
.Value = AddSheetQuestion
.Value = Replace(StrConv(AddSheetQuestion, vbProperCase), " ", "")
End With
Application.Goto Reference:="NewRangeFormat"
Selection.Copy
Application.Goto Reference:="NewRangeInsertLine"
Selection.Insert Shift:=xlDown
Application.Goto Reference:=ActiveSheet.UsedRange
ActiveSheet.Protect ("password")
'add new group to particular KAM's workbook
UpdateKAMsFile = "Promo Plan F08 - " & KAM
With Workbooks.Open(UpdateKAMsFile)
.Sheets("Last").Visible = xlSheetVisible
ThisWorkbook.Sheets(LatestSheet).Copy before:=Worksheets("Last")
.Sheets("Last").Visible = xlSheetVeryHidden
' order Outlet Tabs alphabetically before closing
End With
'Inform the user the macro is completed
MsgBox "The new Outlet Group ''" & AddSheetQuestion & "'' has been added.", _
64, "Sheet addition successful."
End Sub
Function SheetExists(strWSName As String) As Boolean
Dim WS As Worksheet
On Error Resume Next
Set WS = Worksheets(strWSName)
If Not WS Is Nothing Then SheetExists = True
'Boolean function assumed to be False unless set to True
End Function
any ideas??