Private Sub cbCancel_Click()
Unload Me
End Sub
Private Sub cbOk_Click()
Dim lItem As Long
Dim srcWkb As Workbook
Dim destWkb As Workbook
Dim srcShts As Worksheet
Dim objShts As Variant
Dim i As Long
Dim bEnd As Boolean
Application.DisplayAlerts = False
Set srcWkb = ActiveWorkbook
Set objShts = ActiveWindow.SelectedSheets
If cbDest.Value = NEW_BOOK Then
Set destWkb = Application.Workbooks.Add
Else
Set destWkb = Application.Workbooks(cbDest.Value)
End If
If lbDestSht.Value = MOVE_END Then
If cbCopy Then
objShts.Copy after:=destWkb.Sheets(destWkb.Sheets.Count)
Else
objShts.Move after:=destWkb.Sheets(destWkb.Sheets.Count)
End If
Else
For i = 1 To destWkb.Sheets.Count
If destWkb.Sheets(i).Name = lbDestSht.Value Or cbDest.Value = NEW_BOOK Then 'copy or move selected sheets BEFORE the selected destination sheet
If cbCopy Then
objShts.Copy before:=destWkb.Sheets(i)
Else
objShts.Move before:=destWkb.Sheets(i)
End If
Exit For
End If
Next i
End If
Application.DisplayAlerts = True
Unload UserForm1
End Sub
Private Sub cbSource_Change()
Dim mySht As Worksheet
lbDestSht.Clear
For Each mySht In Application.Workbooks(cbSource.Value).Worksheets
lbDestSht.AddItem mySht.Name
Next mySht
End Sub
Private Sub cbDest_Change()
If cbDest.Value <> NEW_BOOK Then
Call loadShts(Application.Workbooks(Me.cbDest.Value))
Else
lbDestSht.Clear
End If
End Sub
Private Sub UserForm_Initialize()
Dim myWkb As Workbook
Dim lItem As Long
'Position Userform relative to sheet selection, as with Native Excel Move/Copy UI
UserForm1.Top = Application.Top + Application.Height * 0.93 - UserForm1.Height
UserForm1.Left = Application.Left + UserForm1.Height * 0.2
cbDest.Clear
cbDest.AddItem NEW_BOOK
For Each myWkb In Application.Workbooks
cbDest.AddItem myWkb.Name
Next myWkb
For lItem = 0 To cbDest.ListCount - 1
If cbDest.List(lItem) = ActiveWorkbook.Name Then
cbDest.ListIndex = lItem
End If
Next lItem
Call loadShts(ActiveWorkbook)
End Sub
Private Sub loadShts(myWkb As Workbook)
Dim lItem As Long
Dim myWks As Object
lbDestSht.Clear
For Each myWks In myWkb.Sheets
lbDestSht.AddItem myWks.Name
Next myWks
lbDestSht.AddItem MOVE_END
lbDestSht.Selected(0) = True
End Sub
And here’s the code that keeps track of the user preference (toggling the Add-in’s features ON or OFF):
Option Explicit
Public Sub MoveOrCopy_toggleStartup()
Dim myName As Name
Dim bStartupState As Boolean
On Error Resume Next
bStartupState = GetSetting("MoveOrCopy!", "StartUp", "State", Environ("username"))
If Err.Number <> 0 Then
bStartupState = True
End If
On Error GoTo 0
bStartupState = Not bStartupState
SaveSetting appname:="MoveOrCopy!", section:="StartUp", Key:="State", setting:=bStartupState
MsgBox "On Excel Restart, MoveOrCopy! will be in " & IIf(bStartupState, "ON", "OFF") & " mode."
End Sub
Finally, here’s the code that interfaces with the command bar or context menu (Excel < 2007 and Excel >=2007, respectively):
Option Explicit
Public Const NEW_BOOK = "(new book)"
Public Const MOVE_END = "(move to end)"
Public bUserDefined As Boolean
Function appVer() As Integer
If UCase(Right(ThisWorkbook.Name, 4)) = ".XLA" Then 'running as a 2003 add-in
appVer = Application.WorksheetFunction.Min(Application.Version, 11)
Else
appVer = Application.Version
End If
End Function
Sub moveOrCopy_Initialize()
bUserDefined = True
If appVer < 12 Then 'check application version. < 12 means earlier than Excel 2007, so use commandbar approach
Call ChangeMenuOptions(bUserDefined, 848) 'True - user defined on move/copy
Else
'do nothing
End If
MsgBox "Just proceed with Move/Copy on sheet tabs as you have 'Normally'. However, use the ""Turn Off"" feature to revert back to Excel Native Move/Copy"
End Sub
Sub moveOrCopy_deInitialize()
bUserDefined = False
If appVer < 12 Then
Call ChangeMenuOptions(bUserDefined, 848) 'True - user defined on move/copy
Else
'do nothing
End If
MsgBox "You have now reverted back to Excel Native Move/Copy"
End Sub
Sub MoveOrCopyUI()
If Application.Workbooks.Count > 0 Then
Load UserForm1
UserForm1.Show
Else
MsgBox "MoveOrCopy! will not operate if no workbooks are open in Excel", vbCritical, "Aborting..."
End If
End Sub
'Source: Adapted from http://social.msdn.microsoft.com/Forums/en-US/vsto/thread/e9aadf58-dbdf-43a1-aae7-e20310880e94/
'------------------------------------------------------------------------------------
'Supporting XML embedded in this 2007/2010 file:
'<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
' <commands>
' <command idMso="SheetMoveOrCopy" onAction="CustomMoveOrCopy" />
' </commands>
'</customUI>
Public Sub CustomMoveOrCopy(ByVal control As Variant, ByRef cancelDefault As Variant)
If bUserDefined Then
cancelDefault = True
Call MoveOrCopyUI
Else
cancelDefault = False
End If
End Sub
'Source: Adapted from http://stackoverflow.com/questions/722409/how-to-capture-worksheet-being-added-through-copy-paste-in-excel-vba
'-----------------------------------------------------------------------------------
Public Sub ChangeMenuOptions(bUserDef As Boolean, ParamArray ControlID() As Variant)
'848 Move or Copy Sheet...
'889 Rename Sheet
'847 Delete Sheet
Dim iControl As Integer
Dim oControl As Object
For iControl = LBound(ControlID) To UBound(ControlID)
For Each oControl In Application.CommandBars.FindControls(ID:=ControlID(iControl))
If bUserDef Then
oControl.OnAction = "MoveOrCopyUI"
Else
oControl.Reset
End If
Next oControl
Next iControl
End Sub
'-----------------------------------------------------------------------------------
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (4)
Commented:
Author
Commented:Dave
Commented:
Sid
Commented: