Input Dates Within A date range Excluding Weekends

[Nathan95]

Hey All

I have the bellow code which takes the inputted start and end date along with the other inputted fields and and lists them besides each individual date within that range on a table in a different sheet.

The issue is that this will list every single date within the range, However I want it to only list the weekdays and not the weekends (Sat and Sun). Any help would be greatly appreciated.

Private Sub cbInputleave_Click()

Dim FirstDate As Date, LastDate As Date
Dim rBlanks As Range
Dim ssheet As Worksheet
Dim ctl As Control

Set ssheet = ThisWorkbook.Sheets("Mark Leave")

FirstDate = tbstartdate.Value
LastDate = tbenddate.Value

With ssheet.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(LastDate - FirstDate + 1)
.Value = Evaluate("Row(" & CLng(FirstDate) & ":" & CLng(LastDate) & ")")
.NumberFormat = "dd-mmm-yy"
.Offset(, 1).Value = cbLeaveType.Value
.Offset(, -2).Value = tbPnumber.Value
.Offset(, -3).Value = ssheet.Evaluate(.Offset(, -2).Address & "&" & .Address)
End With

MsgBox "Leave Entered"

Unload Me




End Sub

 

[Nathan95]

Bump

 

[bebo021999]

There are lots of unknown factors/variable (tbstartdate,tbenddate,cbLeaveType...,), without worksheet sample, its not help a lot.
What are they?

 

[Nathan95]

There are lots of unknown factors/variable (tbstartdate,tbenddate,cbLeaveType...,), without worksheet sample, its not help a lot.
What are they?

They are names of text boxes in a userform

 

[bebo021999]

Try to loop from FirstDate to LastDate, using WEEKDAY function to exclude weekend, then read into a variable array, then write back into sheet
Not test, but try:

Private Sub cbInputleave_Click()
Dim i As Long, k As Long, arr() ' NEW
Dim FirstDate As Date, LastDate As Date
Dim rBlanks As Range
Dim ssheet As Worksheet
Dim ctl As Control
Set ssheet = ThisWorkbook.Sheets("Mark Leave")
FirstDate = tbstartdate.Value
LastDate = tbenddate.Value

'---new added from here
ReDim arr(1 To LastDate - FirstDate + 1, 1 To 1) 
For i = FirstDate To LastDate
    If Weekday(i, 2) < 6 Then
        k = k + 1
        arr(k, 1) = i
    End If
Next
With ssheet.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr), 1) ' NEW
.Value = arr
'-----------
.NumberFormat = "dd-mmm-yy"
.Offset(, 1).Value = cbLeaveType.Value
.Offset(, -2).Value = tbPnumber.Value
.Offset(, -3).Value = ssheet.Evaluate(.Offset(, -2).Address & "&" & .Address)
End With
MsgBox "Leave Entered"
Unload Me
End Sub

 

[Nathan95]

Try to loop from FirstDate to LastDate, using WEEKDAY function to exclude weekend, then read into a variable array, then write back into sheet
Not test, but try:

Private Sub cbInputleave_Click()
Dim i As Long, k As Long, arr() ' NEW
Dim FirstDate As Date, LastDate As Date
Dim rBlanks As Range
Dim ssheet As Worksheet
Dim ctl As Control
Set ssheet = ThisWorkbook.Sheets("Mark Leave")
FirstDate = tbstartdate.Value
LastDate = tbenddate.Value

'---new added from here
ReDim arr(1 To LastDate - FirstDate + 1, 1 To 1)
For i = FirstDate To LastDate
    If Weekday(i, 2) < 6 Then
        k = k + 1
        arr(k, 1) = i
    End If
Next
With ssheet.Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(arr), 1) ' NEW
.Value = arr
'-----------
.NumberFormat = "dd-mmm-yy"
.Offset(, 1).Value = cbLeaveType.Value
.Offset(, -2).Value = tbPnumber.Value
.Offset(, -3).Value = ssheet.Evaluate(.Offset(, -2).Address & "&" & .Address)
End With
MsgBox "Leave Entered"
Unload Me
End Sub

Perfect thanks alot, that worked like a charm

I had another query listed bellow, wondering if you are able to assist with this

Delete Rows of Data in Given Date Range

Hey All I have created a userform where users need to input Start Date (tbstartdate), End Date (tbenddate) and employer number (tbPnumber), based on this user form I want the code to be able to remove/Delete all the rows of data from the table that is located in sheet "Mark Leave" that falls...

www.mrexcel.com