<tbody>
[TD="class: votecell"]
own vote
[/TD]favorite
[TD="class: postcell"]I have an excel workbook with some shapes that act as buttons. On of these shapes has a macro assigned to it that does several things. It creates a new sheet and does several things with this new sheet. One of the things it does is copies a couple of different shapes that are hyperlinked to other sheets in the workbook. The code works, but not always. For some reason sometimes it doesn't copy either shape or might only copy one shape. It works for both shapes about 80% of the time. Here is the section of the code that copies the shapes from other sheets. Can anyone explain why it is not always working?
This is the code for copying the shapes:
Code:
' Copy Index linked button from Calculator sheet
Sheets("Calculator").Shapes("Rounded Rectangle 3").Copy
Range("L3").Select
ActiveSheet.Paste
' Copy Calculator linked button from Index sheet
Sheets("Index").Shapes("Rounded Rectangle 1").Copy
Range("J3").Select
ActiveSheet.PasteThis is the entire code:
Code:
Sub EnterHours2()
' EnterHours2 Macro
' Get current state of various Excel settings so when they are changed in this code they can be return to this state at the end of the code
screenUpdateState = Application.ScreenUpdating
statusBarState = Application.DisplayStatusBar
eventsState = Application.EnableEvents
' Message box if there is no name entered
If Range("F3").Value = "" Then
MsgBox "You Must Enter an Employee Name!"
Range("F3").Select
Exit Sub
End If
' Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :
' Verify that none of these characters are present in the employee name cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Range("F3").Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates naming rules." & vbCrLf & vbCrLf & _
"Please re-enter an employee name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible employee name !!"
Application.EnableEvents = False
Application.EnableEvents = True
Exit Sub
End If
Next i
' Verify that the proposed sheet name (employee name) does not already exist in the workbook
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Range("F3").Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
If bln = False Then
Else
MsgBox "There is already an employee named " & strSheetName & "." & vbCrLf & _
"Please enter a unique employee name."
Application.EnableEvents = False
Application.EnableEvents = True
Exit Sub
End If
' Turn off some Excel functionality so code runs faster
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
' Unprotects workbook if it is protected without a password
ActiveWorkbook.Unprotect
' Unprotects Index sheet
Sheets("Index").Select
ActiveSheet.Unprotect
' Copies worksheet
Sheets("Calculator").Select
Sheets("Calculator").Copy After:=Sheets(2)
' Unprotects worksheet if it is protected without a password
ActiveSheet.Unprotect
' Remove sheet tab color
ActiveSheet.Tab.ColorIndex = xlColorIndexNone
' Makes the class code hours and piece rate figures bold
Range("G10:G17,J18:J20").Select
Selection.Font.Bold = True
' Makes the class code hours and piece rate figures red if greater than zero
Dim myRange As Range
Dim cell As Range
Set myRange = Range("G10:G17,J18:J20")
For Each cell In myRange
If cell.Value > 0 And cell.Value <> "Unknown" Then cell.Font.ColorIndex = 3
Next
' Clears instruction cell and all comments from copy
Range("B22").Select
Selection.ClearContents
Cells.ClearComments
' Change name of title
Range("B1").Select
ActiveCell.FormulaR1C1 = "Hours Recorded " & Format(Now, "mm/dd/yyyy")
' Deletes shapes on copy (buttons)
Dim Shp As Shape
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
' Names the copy of the worksheet to the employee name
Worksheets("Calculator (2)").Name = Range("F3").Value
' Copy Index linked button from Calculator sheet
Sheets("Calculator").Shapes("Rounded Rectangle 3").Copy
Range("L3").Select
ActiveSheet.Paste
' Copy Calculator linked button from Index sheet
Sheets("Index").Shapes("Rounded Rectangle 1").Copy
Range("J3").Select
ActiveSheet.Paste
' Insert Data into index sheet
Dim lRow As Long
Dim ws As Worksheet
Set ws = Worksheets("Index")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
With ws
.Cells(lRow, 1).Value = ActiveSheet.Range("F3").Value
End With
' Protects copy sheet
ActiveSheet.Protect
Range("M20").Select
' Select Index sheet
Sheets("Index").Select
' Hyper link name on to the worksheet that corresponds to it
Range("A1").Select
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Cells(lastRow, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'" & Sheets("Calculator").Range("F3").Value & "'!A1", TextToDisplay:=Sheets("Calculator").Range("F3").Value
' Add background color and border to cell
Range("A1").Select
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Cells(lastRow, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlHairline
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
' Sort list on Index sheet
Range("A2:A1000").Select
ActiveWorkbook.Worksheets("Index").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Index").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Index").Sort
.SetRange Range("A2:A1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
' Protects Index sheet
ActiveSheet.Protect
' Returns to main sheet and clears contents
Sheets("Calculator").Select
Range("D7:D20,G10:G15,F3,F7,N6:N19,J12:J17,L8").Select
Selection.ClearContents
Range("F3").Select
' Restore states, this returns excel functionality that was previously turned off to the state recorded at the beginning of the code
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.EnableEvents = eventsState
' Protects main sheet
ActiveSheet.Protect
ActiveSheet.EnableSelection = xlUnlockedCells
' Protects workbook
ActiveWorkbook.Protect
End Sub[/TD]
</tbody>
