Comparing date with current month and write down a status-CodePudding

I have a macro that checks that a date from a column matches the current month. If yes, writes the status "ok", if it does not match, writes "not ok". For example, today is 28.07.2022. All dates from 01.07 onwards will be ok, any date before 01.07 is "not ok". Everything works fine, but now I need to add a condition to compare not only the current month, but -7 days - i.e. according to our example, dates up to 24.06 inclusive were also with the status "ok".

I will appreciate if some one can help me.

Sub checkdate()
Dim d1 As Date
Dim WSStart As Worksheet
Dim r, lastrow
Dim sFormatDate As String

Set WSStart = ThisWorkbook.Worksheets(1)
lastrow = WSStart.Cells(WSStart.Rows.Count, "G").End(xlUp).Row


d1 = DateSerial(Year(Date), Month(Date), 1)
sFormatDate = Format(d1, "YYYYMM")

For r = 2 To lastrow

dd = WSStart.Cells(r, 7).Value

      If Format(dd, "YYYYMM") <> sFormatDate Then
      WSStart.Cells(r, 11).Value = "not ok"
   Else
      WSStart.Cells(r, 11).Value = "ok"
   End If
 
  Next

 End Sub

CodePudding user response：

Use DateDiff and DateAdd and avoid string handling of dates:

d1 = DateSerial(Year(Date), Month(Date), 1)

If DateDiff("m", Date, DateAdd("d", 6, dd)) <> 0 Then
    WSStart.Cells(r, 11).Value = "not ok"
Else
    WSStart.Cells(r, 11).Value = "ok"
End If

If dd is text, then convert to true DateTime:

If DateDiff("m", Date, DateAdd("d", 6, CDate(Format(dd, "@@@@\/@@")))) <> 0 Then

CodePudding user response：

The new macro, thanks to Gustav :)

Sub checkdate()
Dim d1 As Date
Dim WSStart As Worksheet
Dim r, lastrow
Dim sFormatDate As String

Set WSStart = ThisWorkbook.Worksheets(1)
lastrow = WSStart.Cells(WSStart.Rows.Count, "G").End(xlUp).Row


d1 = DateSerial(Year(Date), Month(Date), 1)


For r = 2 To lastrow
d1 = DateSerial(Year(Date), Month(Date), 1)
dd = WSStart.Cells(r, 7).Value
If DateDiff("m", Date, DateAdd("d", 6, dd)) <> 0 Then
WSStart.Cells(r, 11).Value = "not ok"
Else
WSStart.Cells(r, 11).Value = "ok"

End If
Next


End Sub