Replace code to be able to run on anyday of the week.

K

KyleJackMorrison

Board Regular
Joined
Dec 3, 2013
Messages
107
Office Version
  1. 365
  2. 2021
  3. 2019
Platform
  1. Windows
Hello, so I have a large code which runs a report on dates. I have this code 5 times with just an "offset" +0 +1, +2 +3 +4 (Simulating Monday, Tuesday, Wednesday, Thursday, Friday.)
This code at the moment an ONLY be run on a Monday.
I would like the code to run the weeks report no matter what day it is. Just run this week from moday-friday.


Perhaps replace this with something like:
Code: 
If Cell.Value = [Today()] Then
to something like
Code: 
If cell.value = [Monday of this week] then


(Mondays Code)
Code: 
For Each Cell In ActiveSheet.Range("J10:NJ23")
    If Cell.Value = [Today()] Then
    Cell.Select
    ActiveCell.Offset(1, 0).Select
          Select Case Cell.Column
        Case 10
           Range("K:NO").EntireColumn.Hidden = True
        Case 379
           Range("J:NN").EntireColumn.Hidden = True
        Case Else
           Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
           Range(Cells(11, Cell.Column + 1), Range("NO11")).EntireColumn.Hidden = True
      End Select


(Tuesdays code)
Code: 
For Each Cell In ActiveSheet.Range("J10:NJ23")
    If Cell.Value = [Today()+1] Then
    Cell.Select
    ActiveCell.Offset(1, 0).Select
          Select Case Cell.Column
        Case 10
           Range("K:NO").EntireColumn.Hidden = True
        Case 379
           Range("J:NN").EntireColumn.Hidden = True
        Case Else
           Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
           Range(Cells(11, Cell.Column + 1), Range("NO11")).EntireColumn.Hidden = True
      End Select



(Wednesday code)

Code: 
For Each Cell In ActiveSheet.Range("J10:NJ23")
    If Cell.Value = [Today()+2] Then
    Cell.Select
    ActiveCell.Offset(1, 0).Select
          Select Case Cell.Column
        Case 10
           Range("K:NO").EntireColumn.Hidden = True
        Case 379
           Range("J:NN").EntireColumn.Hidden = True
        Case Else
           Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
           Range(Cells(11, Cell.Column + 1), Range("NO11")).EntireColumn.Hidden = True
      End Select


ect.



TIA
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Sort by date Sort by votes
Hey,

I've been playing around with some functions in Excel and found a way to represent the Monday of the current week.

=TEXT(EDATE(0+TODAY()+IF(WEEKDAY(TODAY(),2)=1,0,1-WEEKDAY(TODAY(),2)),0),"dd/mm/yyyy")

This will output 03/06/2019 (As that was the date on monday), you can change the first 0 in that formula to represent other days (1=tuesday, 2=wednesday etc...) - does this help?
 
Upvote 0
Hello,

VBA Wise it's not too difficult to get the Monday of the week you are in: Not sure I understand fully but going off what you have put I use a function to return the Monday of the week:

Code: 
Function GetMonday() As Date


    Dim d As Date
    
    d = Now
    
    Do Until Format(d, "ddd") = "Mon"
        d = d - 1
    Loop
    
    GetMonday = d
End Function


Sub YourCode()
    Dim d As Date
    
    d = GetMonday
    
    For Each Cell In ActiveSheet.Range("J10:NJ23")
    If Cell.Value = d Then
    Cell.Select
    ActiveCell.Offset(1, 0).Select
          Select Case Cell.Column
        Case 10
           Range("K:NO").EntireColumn.Hidden = True
        Case 379
           Range("J:NN").EntireColumn.Hidden = True
        Case Else
           Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
           Range(Cells(11, Cell.Column + 1), Range("NO11")).EntireColumn.Hidden = True
      End Select
End Sub
 
Upvote 0
@gallen & @tyija1995,

Thank you for your response. Sorry it's difficult to explain.

In cells J10-NJ10 i have dates. 01/01/19 - 31/12/19. I need the code to search for the monday of this current week. Select the cell and then run the code.
Then i can adapt it to run on a tues, wed, thurs and fri.

TIA
 
Upvote 0
Try this.
Code: 
Dim dtMonday As Date
Dim Res As Variant

    dtMonday = Date - Weekday(Date, vbMonday) + 1
    
    Res = Application.Match(CLng(dtMonday), Rows(10), 0)
    
    If Not IsError(Res) Then
        Application.Goto Cells(10, Res)
    End If
 
Upvote 0
Hello, I'm not at a PC so can't really write the code but the "GetMonday" function in my reply does that. If you add the date as an argument, you can pass the date from the cell to it and get the correct Monday

If you are still struggling with how to pass the date to the function let me know and I'll write it out when I'm at a PC
 
Upvote 0
No worries,

Ill try it now, ill post the whole code to give you more of an insite.

Code: 
Public Sub HideMyCells1() 'Monday    Dim objWord As Object
    Dim objDoc As Object
    Dim Cell As Range
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets("FOE Jan 19 - Dec 19").Select


'Search date, hide all but date selected
For Each Cell In ActiveSheet.Range("J10:NJ10")
    If Cell.Value = [Today()] Then
    Cell.Select
    ActiveCell.Offset(1, 0).Select
          Select Case Cell.Column
        Case 10
           Range("K:NO").EntireColumn.Hidden = True
        Case 379
           Range("J:NJ").EntireColumn.Hidden = True
        Case Else
           Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
           Range(Cells(11, Cell.Column + 1), Range("NJ11")).EntireColumn.Hidden = True
      End Select
    
    'Handle Error
    On Error GoTo ErrHandler:
    
    Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(110, 0)).Select


    ' Copy Excel Selection
    Selection.Copy
    ' Create new Word Application
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = False
    ' Create new Word Document
    Set objDoc = objWord.Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
    ' Paste Excel range into Word document
    objWord.Selection.PasteExcelTable False, False, False
    ' Copy text from cells
    If objDoc.Tables.Count >= 1 Then
        objDoc.Tables(1).Select
        objWord.Selection.Copy
    End If
    
    ' Paste to location
    Sheets("Weekly Nominal Role").Select
    Range("F5").Select
    Selection.PasteSpecial xlPasteValues
    
    ' Close Microsoft Word and not save changes
    objWord.Quit False
    Set objWord = Nothing


    Sheets("FOE Jan 19 - Dec 19").Select
    Columns.EntireColumn.Hidden = False
    Rows.EntireRow.Hidden = False
    Sheets("Weekly Nominal Role").Select


'Select Cell
    Range("F3").Select
'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True
'Clear The Clipboard
    Application.CutCopyMode = False
        Exit Sub
    End If
Next Cell


ErrHandler:
    MsgBox "An error has occurred."
exit sub
End Sub
 
Upvote 0
This should point you in the right direction.

All my comments start with a triple star '*** Please read them and ensure you understand

Code: 
Public Sub HideMyCells()
    Dim objWord As Object
    Dim objDoc As Object
    Dim Cell As Range
    Dim dMon As Date '***variable to hold this week's monday
    
    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Sheets("FOE Jan 19 - Dec 19").Select


    '***set the date to today first. ***IMPORTANT*** >> Ensure to format same as cell
    dMon = Format(Now, "dd/mm/yyyy") 'This format worked for how my Excel is set (UK)
    
    'loop backwards a day until you get to Monday
    Do Until Format(dMon, "ddd") = "Mon"
        dMon = dMon - 1
    Loop
    
    '***At this point the variable 'dMon' will be the Monday of the current week


    'Search date, hide all but date selected
    For Each Cell In ActiveSheet.Range("J10:NJ10")
        Select Case Cell.Value
            'only worry about the mon-thursday of this week
            'dMon = Monday, dMon + 1 = Tuesday and so on...
            Case dMon, dMon + 1, dMon + 2, dMon + 3, dMon + 4
                Cell.Select
                ActiveCell.Offset(1, 0).Select
                Select Case Cell.Column
                    Case 10
                       Range("K:NO").EntireColumn.Hidden = True
                    Case 379
                       Range("J:NJ").EntireColumn.Hidden = True
                    Case Else
                       Range("J11", Cells(11, Cell.Column - 1)).EntireColumn.Hidden = True
                       Range(Cells(11, Cell.Column + 1), Range("NJ11")).EntireColumn.Hidden = True
                End Select
                
                'Handle Error
                On Error GoTo ErrHandler:
                
                Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(110, 0)).Select
            
                ' Copy Excel Selection
                Selection.Copy
                ' Create new Word Application
                Set objWord = CreateObject("Word.Application")
                objWord.Visible = False
                ' Create new Word Document
                Set objDoc = objWord.Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
                ' Paste Excel range into Word document
                objWord.Selection.PasteExcelTable False, False, False
                ' Copy text from cells
                If objDoc.Tables.Count >= 1 Then
                    objDoc.Tables(1).Select
                    objWord.Selection.Copy
                End If
                
                ' Paste to location
                Sheets("Weekly Nominal Role").Select
                Range("F5").Select
                Selection.PasteSpecial xlPasteValues
                
                ' Close Microsoft Word and not save changes
                objWord.Quit False
                Set objWord = Nothing
            
            
                Sheets("FOE Jan 19 - Dec 19").Select
                Columns.EntireColumn.Hidden = False
                Rows.EntireRow.Hidden = False
                Sheets("Weekly Nominal Role").Select
            
                'Select Cell
                Range("F3").Select
                'Optimize Code
                Application.ScreenUpdating = True
                Application.EnableEvents = True
                'Clear The Clipboard
                Application.CutCopyMode = False
                Exit Sub '***SHOULD THIS BE HERE??
            Case Else
                '***Any code that needs to run if date is NOT in the current week
        End Select


    Next Cell


Exit Sub '***this line should be here
'*** This code only runs if there's an error
ErrHandler:
    MsgBox Err.Description, vbCritical, "An error has occurred."
    '***Always enusre to renable anything disabled in the event of an error***
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 
Last edited:
Upvote 0
@gallen

Thank you, Works great! Plus its faster than my previous code. Thank you for cleaning up my code too. I'm not the best and quite a messy person when it comes to code.
 
Upvote 0
KyleJackMorrison said:
@gallen

Thank you, Works great! Plus its faster than my previous code. Thank you for cleaning up my code too. I'm not the best and quite a messy person when it comes to code.
Click to expand...

Most welcome.

My code was woeful. I learned through frustration of going back and trying to read what I'd done months/years before to keep it as tidy as possible. Saves a LOT of time down the line.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Assistance changing VBA code to display as HTML or picture of a selection in Lotus Notes
Replies
2
Views
199
jularobert
J
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
888
Legacy 352679
L
M
  • Question Question
Not running code
Replies
0
Views
191
MagicCarpet
M
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
268
tixarah
T
I
  • Question Question
Advice for slight alteration to existing working code
Replies
1
Views
192
ipbr21054
I

Forum statistics

Threads
1,223,238
Messages
6,170,939
Members
452,368
Latest member
jayp2104

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