FATS
New Member
- Joined
- Jan 16, 2009
- Messages
- 37
- Office Version
- 365
- Platform
- Windows
Hello,
Could anyone help me to shorten this sub, I wish to enrol the use of a command to determine multiples, but I don't know how, an 8 year break from VBA has left me feeling rather rusty.
Notice the 4 CASE IS lines indicating every 28 days ago/ahead (months), and every 7 days ago/ahead (weeks). I would like a multiple command to determine this except where its the first multiple.
Thanks in advance.....
Could anyone help me to shorten this sub, I wish to enrol the use of a command to determine multiples, but I don't know how, an 8 year break from VBA has left me feeling rather rusty.
Code:
Sub ScrollDayLabel()
'
ActiveSheet.Shapes("TODAYBOX").OnAction = "ScrollReset"
'
Select Case Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)
'
Case Is = 0
ActiveSheet.Shapes("TODAYBOX").OnAction = ""
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = "TODAY"
'
Case Is = 1
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = "TOMORROW"
'
Case Is = -1
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = "YESTERDAY"
'
Case Is = 28
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = " 1 MONTH AHEAD"
'
[COLOR=#ff0000][B] Case Is = 56, Is = 84, Is = 112, Is = 140, Is = 168, Is = 196, Is = 224, Is = 252, Is = 280, Is = 308, Is = 336, Is = 364[/B][/COLOR]
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
(ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)) / 28 & " MONTHS AHEAD"
'
Case Is = -28
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = " 1 MONTH AGO"
'
[B][COLOR=#ff0000] Case Is = -56, Is = -84, Is = -112, Is = -140, Is = -168, Is = -196, Is = -224, Is = -252, Is = -280, Is = -308, Is = -336, Is = -364[/COLOR][/B]
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
Abs((ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)) / 28) & " MONTHS AGO"
'
Case Is = 7
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = " 1 WEEK AHEAD"
'
[B][COLOR=#ff0000] Case Is = 14, Is = 21, Is = 28, Is = 35, Is = 42, Is = 49, Is = 63, Is = 70, Is = 77, Is = 91, Is = 98, _
[/COLOR][/B][B][COLOR=#ff0000] Is = 105, Is = 119, Is = 126, Is = 133, Is = 147, Is = 154, Is = 161, Is = 175, Is = 182, Is = 189, _
[/COLOR][/B][B][COLOR=#ff0000] Is = 203, Is = 210, Is = 217, Is = 231, Is = 238, Is = 245, Is = 259, Is = 266, Is = 273, Is = 287, Is = 294, _
[/COLOR][/B][B][COLOR=#ff0000] Is = 301, Is = 315, Is = 322, Is = 329, Is = 343, Is = 350, Is = 357[/COLOR][/B]
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
(ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)) / 7 & " WEEKS AHEAD"
'
Case Is = -7
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = " 1 WEEK AGO"
'
[B][COLOR=#ff0000] Case Is = -14, Is = -21, Is = -28, Is = -35, Is = -42, Is = -49, Is = -63, Is = -70, Is = -77, Is = -91, Is = -98, _
[/COLOR][/B][B][COLOR=#ff0000] Is = -105, Is = -119, Is = -126, Is = -133, Is = -147, Is = -154, Is = -161, Is = -175, Is = -182, Is = -189, _
[/COLOR][/B][B][COLOR=#ff0000] Is = -203, Is = -210, Is = -217, Is = -231, Is = -238, Is = -245, Is = -259, Is = -266, Is = -273, Is = -287, Is = -294, _
[/COLOR][/B][B][COLOR=#ff0000] Is = -301, Is = -315, Is = -322, Is = -329, Is = -343, Is = -350, Is = -357[/COLOR][/B]
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
Abs((ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)) / 7) & " WEEKS AGO"
Case Is > 1
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1) & " DAYS AHEAD"
'
Case Is < -1
ActiveSheet.Shapes("TODAYBOX").TextFrame.Characters.Text = _
Abs(ActiveSheet.Range("CurrentDay") - (Fix(DatePart("y", Now())) - 1)) & " DAYS AGO"
End Select
Notice the 4 CASE IS lines indicating every 28 days ago/ahead (months), and every 7 days ago/ahead (weeks). I would like a multiple command to determine this except where its the first multiple.
Thanks in advance.....