Forum Discussion
Sort Arrows not working on table heading
I recently followed a short tutorial to add a time picker into my project. This is the code...
Private Sub Worksheet_Deactivate() Dim TP As Shape On Error Resume Next Set TP = Shapes("TimePickGrp") On Error GoTo 0 If TP Is Nothing Then 'Shape Deleted Application.EnableEvents = False On Error Resume Next Application.Undo Application.EnableEvents = True End If End Sub Private Sub DTPicker21_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date) End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim userSelectedDate As Date 'Show calendar form if selected cell falls within "DateRange" named range If Not Intersect(ActiveCell, Sheet1.Range("DateRange")) Is Nothing Then If IsDate(ActiveCell.value) Then userSelectedDate = ActiveCell.value 'Call CalendarForm userSelectedDate = CalendarForm.GetDate(SelectedDate:=userSelectedDate) 'Make sure user selected a valid date from the CalendarForm If userSelectedDate <> 0 Then ActiveCell.value = userSelectedDate End If Dim TP As Shape On Error Resume Next Set TP = Shapes("TimePickGrp") On Error GoTo 0 If TP Is Nothing Then 'Shape Deleted Application.EnableEvents = False On Error Resume Next Application.Undo On Error GoTo 0 Application.EnableEvents = True End If If Not Intersect(Target, Range("E2:E211")) Is Nothing Then 'If Sheet is Protected, add Unprotect Code here such as ActiveSheet.Unprotect "Password" ActiveSheet.Unprotect "****" TPShow Else: Shapes("TimePickGrp").Visible = msoFalse End If End Sub
*Note I changed the ActiveSheet.Unprotect "Password" part to ***** so I don't have to give away a password I use.
Anyway, this code and module works great when not using a protected sheet, however I wanted my sheet to be protected, so I had to add in the ActiveSheet.Unprotect "Password" line as instructed by the ---> 'If Sheet is Protected, add Unprotect Code here such as ActiveSheet.Unprotect "Password"
You also have to add it into the module code.... see here
Option Explicit Sub UnProtTP() On Error Resume Next ActiveSheet.Shapes("TimePickGrp").Ungroup On Error GoTo 0 'Add in any Unprotect sheet code here such as ActiveSheet.Unprotect "Password" ActiveSheet.Unprotect "*****" 'Application.ScreenUpdating = False Application.ScreenUpdating = False End Sub Sub ProtTP() Dim GrpRange, GrpShapes On Error GoTo ExitSub Set GrpShapes = ActiveSheet.Shapes.Range(Array("MainBack", "BackCircle", "HrsGrp", "8Sel", _ "9Sel", "10Sel", "11Sel", "12Sel", "1Sel", "2Sel", "3Sel", "4Sel", "5Sel", _ "HrsDisp", "Colon", "MinDisp", "AMPM", "AMAct", "PMInact", "DivLine", "DoneBtn" _ , "SettingsBtn", "6Sel", "7Sel", "MinGrp", "PMAct", "AMInact", "00MSel", _ "05MSel", "10MSel", "15MSel", "20MSel", "25MSel", "30MSel", "35MSel", "40MSel", _ "45MSel", "50MSel", "55MSel", "SetGrp")) Set GrpRange = GrpShapes.Group GrpRange.Name = "TimePickGrp" ActiveSheet.Shapes("TimePickGrp").Placement = 2 ExitSub: 'Add in any Protect sheet code here such as ActiveSheet.Protect "Password" ActiveSheet.Protect "*****" 'Application.ScreenUpdating = True Application.ScreenUpdating = True End Sub Sub TPShow() Dim SelCell As Range Dim Hr As Long 'On Error GoTo NoTP 'If Sheet is Protected, add Unprotect Code here such as ActiveSheet.Unprotect "Password" ActiveSheet.Unprotect "*****" With ActiveSheet.Shapes("TimePickGrp") Set SelCell = Selection .Visible = msoCTrue ' On Error Resume Next .Left = SelCell.Left .Top = SelCell.Offset(1, 0).Top ' On Error GoTo 0 End With UnProtTP HideHrSel HideMinSel 'Check for Links from another workbook UnGrpSet If InStr(ActiveSheet.Shapes("5Pie1").OnAction, "!") <> 0 Then 'Run Workbook Link Remover UnGrpHrs UnGrpMin MacroLinkRemover GrpHrs GrpMin GrpSet Else: GrpSet End If If ActiveCell.value <> Empty Then Hr = Format(ActiveCell.value, "hh") If Hr >= 13 Then Hr = Hr - 12 If Hr = 0 Then Hr = 12 If ActiveCell.value <> Empty Then ActiveSheet.Shapes("HrsDisp").TextFrame.Characters.Text = Hr If ActiveCell.value <> Empty Then ActiveSheet.Shapes("MInDisp").TextFrame.Characters.Text = Right(Format(ActiveCell.value, "h:mm"), 2) If ActiveCell.value <> Empty Then ActiveSheet.Shapes("AMPM").TextFrame.Characters.Text = Format(ActiveCell.value, "AM/PM") ActiveSheet.Shapes("SetGrp").Visible = msoFalse HoursDisplay ProtTP 'If Sheet is Protected, Add Protection Code here such as ActiveSheet.Protect "Password" ActiveSheet.Protect "*****" Exit Sub NoTP: MsgBox "The Time Picker has been removed from this sheet. Please copy the entire Time Picker from another sheet and paste it into this sheet" 'If Sheet is Protected, Add Protection Code here such as ActiveSheet.Protect "Password" ActiveSheet.Protect "*****" End Sub Sub HoursDisplay() Dim Siz, CurLeft, CurTop As Long With ActiveSheet UnProtTP HideMinSel HideHrSel .Shapes("MinDisp").TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) .Shapes("HrsDisp").TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0) If ActiveCell.value = Empty Then 'Set Default TIme to 12PM .Shapes("HrsDisp").TextFrame.Characters.Text = "12" .Shapes("MinDisp").TextFrame.Characters.Text = "00" .Shapes("AMPM").TextFrame.Characters.Text = "PM" End If .Shapes("MinGrp").Visible = False With .Shapes("HrsGrp") .Visible = True CurLeft = .Left CurTop = .Top For Siz = 180 To 152 Step -4 .Width = Siz .Height = Siz .Left = 152 - Siz + CurLeft .Top = 152 - Siz + CurTop Application.Wait (Now + 0#) Next Siz End With On Error Resume Next .Shapes(.Shapes("HrsDisp").TextFrame.Characters.Text & "Sel").Visible = True On Error GoTo 0 ProtTP End With End Sub Sub MinDisplay() Dim Siz, CurLeft, CurTop As Long Dim Inter As String Dim Intg5, Intg10, Intg15 As Integer With ActiveSheet UnProtTP Intg5 = .Shapes("5MinTxt").Fill.Visible Intg10 = .Shapes("10MinTxt").Fill.Visible Intg15 = .Shapes("15MinTxt").Fill.Visible If Intg5 = -1 Then Inter = "5M" If Intg10 = -1 Then Inter = "10M" If Intg15 = -1 Then Inter = "15M" HideHrSel .Shapes("HrsDisp").TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) .Shapes("MInDisp").TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 0, 0) .Shapes("HrsGrp").Visible = False .Shapes("MinGrp").Visible = True If Inter = "10M" Or Inter = "15M" Then .Shapes("05Min").Visible = False If Inter = "15M" Then .Shapes("10Min").Visible = False If Inter = "10M" Then .Shapes("15Min").Visible = False If Inter = "15M" Then .Shapes("20Min").Visible = False If Inter = "10M" Or Inter = "15M" Then .Shapes("25Min").Visible = False If Inter = "10M" Or Inter = "15M" Then .Shapes("35Min").Visible = False If Inter = "15M" Then .Shapes("40Min").Visible = False If Inter = "10M" Then .Shapes("45Min").Visible = False If Inter = "15M" Then .Shapes("50Min").Visible = False If Inter = "10M" Or Inter = "15M" Then .Shapes("55Min").Visible = False With .Shapes("MinGrp") ' .Visible = True CurLeft = .Left CurTop = .Top For Siz = 126 To 152 Step 2 .Width = Siz .Height = Siz .Left = 152 - Siz + CurLeft .Top = 152 - Siz + CurTop Application.Wait (Now + 0#) Next Siz End With On Error Resume Next .Shapes(.Shapes("MinDisp").TextFrame.Characters.Text & "MSel").Visible = True On Error GoTo 0 ProtTP End With End Sub Sub HideHrSel() With ActiveSheet .Shapes("1Sel").Visible = False .Shapes("2Sel").Visible = False .Shapes("3Sel").Visible = False .Shapes("4Sel").Visible = False .Shapes("5Sel").Visible = False .Shapes("6Sel").Visible = False .Shapes("7Sel").Visible = False .Shapes("8Sel").Visible = False .Shapes("9Sel").Visible = False .Shapes("10Sel").Visible = False .Shapes("11Sel").Visible = False .Shapes("12Sel").Visible = False End With End Sub Sub HideMinSel() With ActiveSheet .Shapes("05MSel").Visible = False .Shapes("10MSel").Visible = False .Shapes("15MSel").Visible = False .Shapes("20MSel").Visible = False .Shapes("25MSel").Visible = False .Shapes("30MSel").Visible = False .Shapes("35MSel").Visible = False .Shapes("40MSel").Visible = False .Shapes("45MSel").Visible = False .Shapes("50MSel").Visible = False .Shapes("55MSel").Visible = False .Shapes("00MSel").Visible = False End With End Sub Sub AMPMSel() If ActiveSheet.Shapes("AMPM").TextFrame.Characters.Text = "AM" Then PMSel Else: AMSel End Sub Sub AMSel() UnProtTP With ActiveSheet .Shapes("AMPM").TextFrame.Characters.Text = "AM" .Shapes("AMAct").Visible = True .Shapes("AMInact").Visible = False .Shapes("PMAct").Visible = False .Shapes("PMInact").Visible = True End With ProtTP End Sub Sub PMSel() UnProtTP With ActiveSheet .Shapes("AMPM").TextFrame.Characters.Text = "PM" .Shapes("AMAct").Visible = False .Shapes("AMInact").Visible = True .Shapes("PMAct").Visible = True .Shapes("PMInact").Visible = False End With ProtTP End Sub Sub Select1() UnProtTP HideHrSel With ActiveSheet .Shapes("1Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "1" MinDisplay End With ProtTP End Sub Sub Select2() UnProtTP HideHrSel With ActiveSheet .Shapes("2Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "2" If .Shapes("HrsGrp").Visible = True Then MinDisplay End With ProtTP End Sub Sub Select3() UnProtTP HideHrSel With ActiveSheet .Shapes("3Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "3" MinDisplay End With ProtTP End Sub Sub Select4() UnProtTP HideHrSel With ActiveSheet .Shapes("4Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "4" MinDisplay End With ProtTP End Sub Sub Select5() UnProtTP HideHrSel With ActiveSheet .Shapes("5Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "5" MinDisplay End With ProtTP End Sub Sub Select6() UnProtTP HideHrSel With ActiveSheet .Shapes("6Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "6" MinDisplay End With ProtTP End Sub Sub Select7() UnProtTP HideHrSel With ActiveSheet .Shapes("7Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "7" MinDisplay End With ProtTP End Sub Sub Select8() UnProtTP HideHrSel With ActiveSheet .Shapes("8Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "8" MinDisplay End With ProtTP End Sub Sub Select9() UnProtTP HideHrSel With ActiveSheet .Shapes("9Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "9" MinDisplay End With ProtTP End Sub Sub Select10() UnProtTP HideHrSel With ActiveSheet .Shapes("10Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "10" MinDisplay End With ProtTP End Sub Sub Select11() UnProtTP HideHrSel With ActiveSheet .Shapes("11Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "11" MinDisplay End With ProtTP End Sub Sub Select12() UnProtTP HideHrSel With ActiveSheet .Shapes("12Sel").Visible = True .Shapes("HrsDisp").TextFrame.Characters.Text = "12" MinDisplay End With ProtTP End Sub Sub SelectM00() UnProtTP HideMinSel With ActiveSheet .Shapes("00MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "00" End With ProtTP End Sub Sub SelectM05() UnProtTP HideMinSel With ActiveSheet .Shapes("05MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "05" End With ProtTP End Sub Sub SelectM10() UnProtTP HideMinSel With ActiveSheet .Shapes("10MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "10" End With ProtTP End Sub Sub SelectM15() UnProtTP HideMinSel With ActiveSheet .Shapes("15MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "15" End With ProtTP End Sub Sub SelectM20() UnProtTP HideMinSel With ActiveSheet .Shapes("20MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "20" End With ProtTP End Sub Sub SelectM25() UnProtTP HideMinSel With ActiveSheet .Shapes("25MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "25" End With ProtTP End Sub Sub SelectM30() UnProtTP HideMinSel With ActiveSheet .Shapes("30MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "30" End With ProtTP End Sub Sub SelectM35() UnProtTP HideMinSel With ActiveSheet .Shapes("35MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "35" End With ProtTP End Sub Sub SelectM40() UnProtTP HideMinSel With ActiveSheet .Shapes("40MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "40" End With ProtTP End Sub Sub SelectM45() UnProtTP HideMinSel With ActiveSheet .Shapes("45MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "45" End With ProtTP End Sub Sub SelectM50() UnProtTP HideMinSel With ActiveSheet .Shapes("50MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "50" End With ProtTP End Sub Sub SelectM55() UnProtTP HideMinSel With ActiveSheet .Shapes("55MSel").Visible = True .Shapes("MinDisp").TextFrame.Characters.Text = "55" End With ProtTP End Sub Sub DoneBtn() With ActiveSheet ActiveCell.value = .Shapes("HrsDisp").TextFrame.Characters.Text & ":" & .Shapes("MinDisp").TextFrame.Characters.Text & " " & .Shapes("AMPM").TextFrame.Characters.Text .Shapes("TimePickGrp").Visible = False 'SetHideShow End With End Sub Sub SetHideShow() With ActiveSheet UnProtTP If .Shapes("SetGrp").Visible = False Then .Shapes("SetGrp").Visible = msoCTrue Else .Shapes("SetGrp").Visible = False End If End With ProtTP End Sub Sub Set5MinInt() With ActiveSheet .Shapes("5MinTxt").Fill.ForeColor.RGB = RGB(140, 58, 58) .Shapes("5MinTxt").Fill.Visible = msoCTrue .Shapes("10MinTxt").Fill.Visible = msoFalse .Shapes("15MinTxt").Fill.Visible = msoFalse End With MinDisplay SelectM00 End Sub Sub Set10MinInt() With ActiveSheet .Shapes("10MinTxt").Fill.ForeColor.RGB = RGB(140, 58, 58) .Shapes("10MinTxt").Fill.Visible = msoCTrue .Shapes("5MinTxt").Fill.Visible = msoFalse .Shapes("15MinTxt").Fill.Visible = msoFalse End With MinDisplay SelectM00 End Sub Sub Set15MinInt() With ActiveSheet .Shapes("15MinTxt").Fill.ForeColor.RGB = RGB(140, 58, 58) .Shapes("15MinTxt").Fill.Visible = msoCTrue .Shapes("10MinTxt").Fill.Visible = msoFalse .Shapes("5MinTxt").Fill.Visible = msoFalse End With MinDisplay SelectM00 End Sub Sub SetThm1() ActiveSheet.Shapes.Range(Array("SetBack", "MainBack")).Fill.ForeColor.RGB = RGB(64, 64, 64) ActiveSheet.Shapes("BackCircle").Fill.ForeColor.RGB = RGB(54, 54, 54) End Sub Sub SetThm2() ActiveSheet.Shapes.Range(Array("SetBack", "MainBack")).Fill.ForeColor.RGB = RGB(55, 96, 146) ActiveSheet.Shapes("BackCircle").Fill.ForeColor.RGB = RGB(37, 64, 97) End Sub Sub SetThm3() ActiveSheet.Shapes.Range(Array("SetBack", "MainBack")).Fill.ForeColor.RGB = RGB(119, 147, 60) ActiveSheet.Shapes("BackCircle").Fill.ForeColor.RGB = RGB(79, 98, 40) End Sub Sub SetThm4() ActiveSheet.Shapes.Range(Array("SetBack", "MainBack")).Fill.ForeColor.RGB = RGB(96, 74, 123) ActiveSheet.Shapes("BackCircle").Fill.ForeColor.RGB = RGB(64, 49, 82) End Sub Sub SetThm5() ActiveSheet.Shapes.Range(Array("SetBack", "MainBack")).Fill.ForeColor.RGB = RGB(49, 133, 156) ActiveSheet.Shapes("BackCircle").Fill.ForeColor.RGB = RGB(33, 89, 104) End Sub Sub UnGrpHrs() On Error Resume Next ActiveSheet.Shapes("HrsGrp").Ungroup On Error GoTo 0 End Sub Sub GrpHrs() Dim GrpRange, GrpShapes On Error GoTo ExitSub Set GrpShapes = ActiveSheet.Shapes.Range(Array("1Hr", "2Hr", "3Hr", "4Hr", "5Hr", "6Hr", "7Hr", "8Hr", "9Hr", "10Hr", "11Hr", "12Hr")) Set GrpRange = GrpShapes.Group GrpRange.Name = "HrsGrp" ExitSub: End Sub Sub UnGrpMin() On Error Resume Next ActiveSheet.Shapes("MinGrp").Ungroup On Error GoTo 0 End Sub Sub GrpMin() Dim GrpRange, GrpShapes On Error GoTo ExitSub Set GrpShapes = ActiveSheet.Shapes.Range(Array("00Min", "05Min", "10Min", "15Min", "20Min", "25Min", "30Min", "35Min", "40Min", "45Min", "50Min", "55Min")) Set GrpRange = GrpShapes.Group GrpRange.Name = "MinGrp" ExitSub: End Sub Sub UnGrpSet() On Error Resume Next ActiveSheet.Shapes("SetGrp").Ungroup ActiveSheet.Shapes("5Thm").Ungroup ActiveSheet.Shapes("4Thm").Ungroup ActiveSheet.Shapes("3Thm").Ungroup ActiveSheet.Shapes("2Thm").Ungroup ActiveSheet.Shapes("1Thm").Ungroup ActiveSheet.Shapes("5MinGrp").Ungroup ActiveSheet.Shapes("10MinGrp").Ungroup ActiveSheet.Shapes("15MinGrp").Ungroup On Error GoTo 0 End Sub Sub GrpSet() Dim GrpRange, GrpShapes On Error GoTo ExitSub Set GrpShapes = ActiveSheet.Shapes.Range(Array("5Pie1", "5Pie2")) Set GrpRange = GrpShapes.Group GrpRange.Name = "5Thm" Set GrpShapes = ActiveSheet.Shapes.Range(Array("4Pie1", "4Pie2")) Set GrpRange = GrpShapes.Group GrpRange.Name = "4Thm" Set GrpShapes = ActiveSheet.Shapes.Range(Array("3Pie1", "3Pie2")) Set GrpRange = GrpShapes.Group GrpRange.Name = "3Thm" Set GrpShapes = ActiveSheet.Shapes.Range(Array("2Pie1", "2Pie2")) Set GrpRange = GrpShapes.Group GrpRange.Name = "2Thm" Set GrpShapes = ActiveSheet.Shapes.Range(Array("1Pie1", "1Pie2")) Set GrpRange = GrpShapes.Group GrpRange.Name = "1Thm" Set GrpShapes = ActiveSheet.Shapes.Range(Array("5MinPie", "5MinTxt")) Set GrpRange = GrpShapes.Group GrpRange.Name = "5MinGrp" Set GrpShapes = ActiveSheet.Shapes.Range(Array("10MinPie", "10MinTxt")) Set GrpRange = GrpShapes.Group GrpRange.Name = "10MinGrp" Set GrpShapes = ActiveSheet.Shapes.Range(Array("15MinPie", "15MinTxt")) Set GrpRange = GrpShapes.Group GrpRange.Name = "15MinGrp" Set GrpShapes = ActiveSheet.Shapes.Range(Array("SetBack", "1Thm", "2Thm", "3Thm", "4Thm", "5Thm", "IntTxt", "ThmTxt", "5MinGrp", "10MinGrp", "15MinGrp")) Set GrpRange = GrpShapes.Group GrpRange.Name = "SetGrp" ExitSub: End Sub Sub MacroLinkRemover() 'PURPOSE: Remove an external workbook reference from all shapes triggering macros 'Source: www.ExcelForFreelancers.com Dim shp As Shape Dim MacroLink, NewLink As String Dim SplitLink As Variant For Each shp In ActiveSheet.Shapes 'Loop through each shape in worksheet 'Grab current macro link (if available) On Error GoTo NextShp MacroLink = shp.OnAction 'Determine if shape was linking to a macro If MacroLink <> "" And InStr(MacroLink, "!") <> 0 Then 'Split Macro Link at the exclaimation mark (store in Array) SplitLink = Split(MacroLink, "!") 'Pull text occurring after exclaimation mark NewLink = SplitLink(1) 'Remove any straggling apostrophes from workbook name If Right(NewLink, 1) = "'" Then NewLink = Left(NewLink, Len(NewLink) - 1) End If 'Apply New Link shp.OnAction = NewLink End If NextShp: Next shp End Sub
So after I did this I was happy to see that the time picker now works when protecting the sheet!
Only problem is, the sort arrows in the table headings are no longer selectable. I can't use them. Can someone help? I'm assuming it has something to do with the code. Also, they are not locked, so that's not the problem.