Clickable annual wheel

Hi daredan,

I love your wheel. Try the attached file. However, I didn't implement the year part, because I didn't see any Year segments.

This is how I approached your problem:
a. Macro 'RenameAciveShape()' was used to rename the segments to 'Jan' thru 'Dec'.
b. Macro 'AssignOnActionTextToWheelSegments()' was used to assign Macro 'WheelEventHandler()' as the Event Handler for all Shapes on the Sheet.
c. Macro 'WheelEventHandler()' processes CLICKS on the Wheel and puts the month in cell 'H1'.

Code follows (ordinary code module such as 'Module1'):

Option Explicit

Sub AssignOnActionTextToWheelSegments()
  'This assigns macro 'WheelEventHandler' as the Event Handler for all Shapes on the Sheet
  
  Dim Sh As Object
    
  For Each Sh In ActiveSheet.Shapes
    Sh.OnAction = "WheelEventHandler"
  Next Sh
  
End Sub

Sub RenameAciveShape()

  Dim sNewName As String
  
  sNewName = InputBox("Enter a 3 letter month then select 'OK'", "Rename Wheel Segment Input Box")

  Selection.ShapeRange.Name = sNewName

End Sub



Sub WheelEventHandler()
  'This is the Wheel Segment Event Handler that assigns a month to cell 'H1'
  
  Dim bHaveValidMonth As Boolean

  Dim sMonth As String
  Dim sUpperCaseMonth As String

  'Get the name of the Shape that was selected
  'Debug.Print Application.Caller
  sMonth = Application.Caller
  sUpperCaseMonth = UCase(sMonth)

  'Test to see if the Shape selected was a month
  Select Case sUpperCaseMonth
    Case "JAN"
      bHaveValidMonth = True
    Case "FEB"
      bHaveValidMonth = True
    Case "MAR"
      bHaveValidMonth = True
    Case "APR"
      bHaveValidMonth = True
    Case "MAY"
      bHaveValidMonth = True
    Case "JUN"
      bHaveValidMonth = True
    Case "JUL"
      bHaveValidMonth = True
    Case "AUG"
      bHaveValidMonth = True
    Case "SEP"
      bHaveValidMonth = True
    Case "OCT"
      bHaveValidMonth = True
    Case "NOV"
      bHaveValidMonth = True
    Case "DEC"
      bHaveValidMonth = True
  End Select

  'If the shape selected was a month, then assign the value to cell 'H1'
  If bHaveValidMonth = True Then
    ActiveSheet.Range("H1").Value = sMonth
  End If
  
End Sub

Lewis

Thanks a stack Lewis. I'll start implementing and understanding your approach and will save a version including years when done. I should be able to include this part as it'll be hardly any different from your solution for the months.
/Daniel

Hi again,

I hate to admit it, but although I consider myself having at least some basic VBA knowledge this seems to exceed my current horizon (I'll have to work on that).

I tried to incorporate your macro with the revised annual wheel (months and years) in the file, where I intend to use it, but failed both to activate your code so that the month would be updated (now in B2) and also to include the year as it's not just some simple copying of the monthly code. Also when I try to initially run the RenameActiveShape it only returns with a Runtime 438 'Object doesn't support this property or method'.

So I have included now the whole thing, where the wheel is supposed to work in, which is a recurring task list plus a Gantt chart visualisation. For the latter I have another problem, but that's already posted in the chart section of this forum.

Sorry for the troubles - really appreciate that it's generally working fine

/Daniel

Good day,
I've solved the issue by using a simple macro per shape. Works like a charm as well.

Option Explicit

Sub Jan_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "January"
End Sub
Sub Feb_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "February"
End Sub
Sub Mar_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "March"
End Sub
Sub Apr_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "April"
End Sub
Sub May_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "May"
End Sub
Sub Jun_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "June"
End Sub
Sub Jul_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "July"
End Sub
Sub Aug_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "August"
End Sub
Sub Sep_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "September"
End Sub
Sub Oct_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "October"
End Sub
Sub Nov_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "November"
End Sub
Sub Dec_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "December"
End Sub
Sub yr2014_Click()
    Range("B3").Select
    ActiveCell.FormulaR1C1 = 2014
End Sub
Sub yr2015_Click()
    Range("B3").Select
    ActiveCell.FormulaR1C1 = 2015
End Sub
Sub yr2016_Click()
    Range("B3").Select
    ActiveCell.FormulaR1C1 = 2016
End Sub
Sub yr2017_Click()
    Range("B3").Select
    ActiveCell.FormulaR1C1 = 2017
End Sub

Admit it could potentially be more fancy, but does what it's supposed to do.

Cheers,
Daniel

Hi Daniel,

I want to apologize for two things:
a. The problems you were having.
b. I missed your second post from yesterday at 9:57AM

I like your solution much better than mine. I was trying to avoid extra code, but cause unintended consequences instead.

For the future you can simplify things a little. You can replace

Sub Jan_Click()
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "January"
End Sub

with

Sub Jan_Click()
    Range("B2") = "January"
End Sub

I wouldn't change anything now, because what you have works.

Lewis

No worries Lewis. Without your help I might still be stuck, so thanks for your guidance.
Cheers,
Daniel

some changes to
1) Sub WheelEventHandler
2) shapes name
3) formulas in cells

AnnalWheel_DRAFT_V2.xlsm

Interesting approach on the formula. Thanks.
Also like the compressed macro.