VBA mutiples of...

FATS

FATS

New Member
Joined
Jan 16, 2009
Messages
37
Office Version
  1. 365
Platform
  1. 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. :laugh:

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.....
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Try testing various values with this
Code: 
Sub TestSelectCase()
    Dim x As Integer, msg As String, When As String
        x = Application.InputBox("number")
        If x > 0 Then When = "AHEAD" Else When = "AGO"
    Select Case x
        Case 0:     msg = "TODAY"
            
        Case 1:     msg = "TOMORROW"
            
        Case -1:    msg = "YESTERDAY"
            
        Case 28:    msg = "1 MONTH AHEAD"
 
        Case -28:   msg = "1 MONTH AGO"
        
        Case 7:     msg = "1 WEEK AHEAD"
        
        Case -7:    msg = " 1 WEEK AGO"
        
        Case Else
                If x Mod 28 = 0 Then
                    msg = x / 28 & " MONTHS " & When
                ElseIf x Mod 7 = 0 Then
                    msg = x / 7 & " WEEKS " & When
                Else
                    msg = x & " DAYS " & When
                End If
    End Select
    MsgBox msg
End Sub
 
Upvote 0
Yongle said:
Try testing various values with this
Code: 
Sub TestSelectCase()
    Dim x As Integer, msg As String, When As String
        x = Application.InputBox("number")
        If x > 0 Then When = "AHEAD" Else When = "AGO"
    Select Case x
        Case 0:     msg = "TODAY"
            
        Case 1:     msg = "TOMORROW"
            
        Case -1:    msg = "YESTERDAY"
            
        Case 28:    msg = "1 MONTH AHEAD"
 
        Case -28:   msg = "1 MONTH AGO"
        
        Case 7:     msg = "1 WEEK AHEAD"
        
        Case -7:    msg = " 1 WEEK AGO"
        
        Case Else
                If x Mod 28 = 0 Then
                    msg = x / 28 & " MONTHS " & When
                ElseIf x Mod 7 = 0 Then
                    msg = x / 7 & " WEEKS " & When
                Else
                    msg = x & " DAYS " & When
                End If
    End Select
    MsgBox msg
End Sub
Click to expand...

Thanks mate, I believe I can adapt this logic most suitably. :bow:
 
Upvote 0
Just to add, it can sometimes be easier to break the calculation part out from the main sub with a function, usually helps when you're tweaking the logic but avoid disturbing other parts of the code, i.e.
Rich (BB code): 
Sub TestSelectCase()

    Dim x As Long
    Dim msg As String
    
    x = Application.InputBox("Number: ")
    msg = IIf(x > 0, "AHEAD", "AGO")
    
    MsgBox MyStringFunction(x, msg), vbExclamation, ""
    
    'Or if you're using a loop, i.e. different things to consider
    ' For x = 1 to 5
    '  MyStringFunction(x, "AHEAD")
    ' Next x


End Sub

Private Function MyStringFunction(ByRef x As Long, ByRef msg As String) As String

    Select Case x
        Case 0: MyStringFunction = "TODAY"
        Case 1: MyStringFunction = "TOMORROW"
        Case -1: MyStringFunction = "YESTERDAY"
        
        Case 28: MyStringFunction = "1 MONTH AHEAD"
        Case -28: MyStringFunction = "1 MONTH AGO"
        
        Case 7: MyStringFunction = "1 WEEK AHEAD"
        Case -7: MyStringFunction = " 1 WEEK AGO"
        
        Case Else
                If x Mod 28 = 0 Then
                    MyStringFunction = x / 28 & " MONTHS " & msg
                ElseIf x Mod 7 = 0 Then
                    MyStringFunction = x / 7 & " WEEKS " & msg
                Else
                    MyStringFunction = x & " DAYS " & msg
                End If
    End Select

End Function
 
Last edited:
Upvote 0
JackDanIce said:
Just to add, it can sometimes be easier to break the calculation part out from the main sub with a function, usually helps when you're tweaking the logic but avoid disturbing other parts of the code, i.e.
Rich (BB code): 
Sub TestSelectCase()

    Dim x As Long
    Dim msg As String
    
    x = Application.InputBox("Number: ")
    msg = IIf(x > 0, "AHEAD", "AGO")
    
    MsgBox MyStringFunction(x, msg), vbExclamation, ""
    
    'Or if you're using a loop, i.e. different things to consider
    ' For x = 1 to 5
    '  MyStringFunction(x, "AHEAD")
    ' Next x


End Sub

Private Function MyStringFunction(ByRef x As Long, ByRef msg As String) As String

    Select Case x
        Case 0: MyStringFunction = "TODAY"
        Case 1: MyStringFunction = "TOMORROW"
        Case -1: MyStringFunction = "YESTERDAY"
        
        Case 28: MyStringFunction = "1 MONTH AHEAD"
        Case -28: MyStringFunction = "1 MONTH AGO"
        
        Case 7: MyStringFunction = "1 WEEK AHEAD"
        Case -7: MyStringFunction = " 1 WEEK AGO"
        
        Case Else
                If x Mod 28 = 0 Then
                    MyStringFunction = x / 28 & " MONTHS " & msg
                ElseIf x Mod 7 = 0 Then
                    MyStringFunction = x / 7 & " WEEKS " & msg
                Else
                    MyStringFunction = x & " DAYS " & msg
                End If
    End Select

End Function
Click to expand...

You're right, of course! :grin:
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
1K
AndyEd
A
A
  • Solved
Calendar issue
Replies
1
Views
2K
AndyEd
A
L
  • Question Question
VBA works on work PC but not home PC
Replies
3
Views
2K
rollis13
rollis13
B
  • Solved
Add a formula in 28th row
2
Replies
11
Views
204
bdt
B
T
  • Question Question
INDEX and MATCH formula for rainfall cessation
Replies
6
Views
300
Eric W
Eric W

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top