Business Day through VBA on a range of cells

Hi Experts,

Quick and small help required. I googled quite a lot for this but was unable to find any.

I want to input the Yesterday's Business Date on a range of cells say for E.g from column L2-L59.

Two criteria's are important.

1) Should be yesterday's business date. I.e. If today is 08/06/2014 then my the code should update as 08/05/2014. If i am running the code on a Monday, then it should update the date as friday.

2) The range can vary. Today it might be from L2-L59, tomorrow it can be L2-L70.


Can you please help.

hi aaron.mendes, option

Hi watersev,

Thanks. I inserted your code in my macro but somehow this is not working. Have i missed something or inputted a wrong function?

My code is at the end just before the save as csv code begins. Please can you help.

Sub Collateral_Report()
Rows("1:3").Delete

Range("D1").EntireColumn.Insert
Range("L1").EntireColumn.Insert

Range("D1").Select
ActiveCell.FormulaR1C1 = "Clearing House"

Range("L1").Select
ActiveCell.FormulaR1C1 = "Exposure Date"

Columns("F:F").Select
    Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Columns("N:N").Select
    Selection.TextToColumns Destination:=Range("N1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Columns("O:O").Select
    Selection.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
    Columns("R:R").Select
    Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True

Columns("A:V").NumberFormat = "@"


ActiveSheet.UsedRange.Select

Dim i As Long

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False

For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With


Range("A1").Select

'Range("l2:l59").Value = DateSerial(2014, 8, 4)

If Intersect(Target, Range("L2:L" & Rows.Count)) Is Nothing Then Exit Sub
If Not IsDate(Target.Cells(1)) Then Exit Sub

Application.EnableEvents = 0
Target.Value = DateAdd("d", Choose(Weekday(Target.Cells(1), vbMonday), -3, -1, -1, -1, -1, -1, -2), Target.Cells(1))
Application.EnableEvents = 1

Application.GetSaveAsFilename

Dim fname As String
fname = Application.GetSaveAsFilename(InitialFileName:="", FileFilter:="CSV (Comma delimited) (*.csv), *.csv", Title:="Save As")
fname = Trim(fname) 'remove leading and trailing blanks
If Len(fname) = 0 Then Exit Sub
ActiveWorkbook.SaveAs Filename:=fname, FileFormat:=xlCSV

End Sub

hi aaron, the code provided should reside in Sheet level and will not work in a standard module as it is an event code. If you do not want an event code (triggered by changing value in L column) the code should be rewritten

Hi Watersev - I'm an amateur in VBA and I am still learning to write codes. The above code that I pasted, is just a result of quite a lot of copy paste, trial and error and ofcourse google

If the code has to be rewritten, would you please help.

please check attachment, press Run button or run code "test1"(ALT+F8, select "test1", Run)