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
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
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
Related
So I have a list of dates that I am trying to search through and check if they need to be corrected or not. The yellow highlighted cells are examples of changes needed to be made. Wether the date needs fixing or not I want the result of the code to place it in the "Date Fixed" column as shown in the first cell. If the date is not listed as the 30/31st of a month or the 1st then I need to change the day part of the date to either the beginning or end of the month. I have written what I thought would work but I keep receiving a Run Time Error 11 code. Any ideas on how to fix this and keep going through all the dates?
Private Sub FormatDate_Click()
Dim myrow As Integer
Dim startrow As Integer
Dim Dates As Date
Dim Datesfixed As Date
Dim dateTwo As Date
Dim dateEnd As Date
myrow = 2
startrow = 2
Dates = Cells(myrow, 2)
Datesfixed = Cells(myrow, 3)
dateTwo = mm / 1 / yyyy
dateEnd = mm / 31 / yyyy
Do Until Cells(myrow, 1) = ""
If Dates = dateTwo Or dateEnd Then
Datesfixed = Dates
ElseIf Dates <> dateTwo Or dateEnd Then
Dates = dateTwo
myrow = myrow + 1
End If
myrow = myrow + 1
Loop
myrow = 2
startrow = 2
End Sub
Try something like this:
Private Sub FormatDate_Click()
Dim c As Range, dt, d As Long, m As Long, y As Long, dLast As Long
Set c = ActiveSheet.Range("B2") 'first date
Do While Len(c.Value) > 0
dt = c.Value
d = Day(dt) 'extract the parts of the date
m = Month(dt)
y = Year(dt)
dLast = Day(DateAdd("m", 1, DateSerial(y, m, 1)) - 1) 'last day of the month
If d <> 1 And d <> dLast Then
c.Offset(0, 1) = DateSerial(y, m, dLast) 'set to last day of the month
End If
Set c = c.Offset(1, 0) 'next date
Loop
End Sub
This is a silly question, but I can't seem to find the issue with the code after a lot of hunting. I'm creating a For Each loop that finds all incidences of "Friday," goes over to the cell 6 columns over from "Friday" (under the "Overtime" heading), inserts the number 0 in that cell, and changes the number format. Here is my worksheet so far.
Here is my code:
Sub Calendar_Generator()
Dim WS As Worksheet
Dim MyInput As String
Dim StartDay As Date
Dim Sp() As String
Dim a As Integer
Dim R As Long
Dim Match As Range
Dim b As Variant
Dim DayNames() As String
Dim FirstAddress As String
Dim DeleteDays As Range
Dim c As Variant
Dim Day1 As Range
Dim WorkDays As Range
Dim d As Variant
'Dim Fri As Range
Set WS = ActiveWorkbook.ActiveSheet
WS.Range("A1:R100").Clear
'This loop is crashing excel
'Do
MyInput = InputBox("Enter the start date for the Calendar:")
'If MyInput = "" Then Exit Sub
'Loop While Not IsDate(MyInput)
' repeat if entry isn't recognized as a date
' Set the date value of the beginning of inputted month.
' -- regardless of the day the user entered, even if missing
StartDay = DateSerial(Year(CDate(MyInput)), Month(CDate(MyInput)), 1)
'Set headers
Range("a1").Value = Format(StartDay, "mmmm") & " Time Sheet"
Sp = Split("Day,Date,Time In,Time Out,Hours,Notes,Overtime", ",")
For a = 0 To UBound(Sp)
WS.Cells(2, 1 + a).Value = Sp(a)
Next a
' fill the days for the selected month
' == the last day of a month is always the day before the first of the next
' here deducting 2 to count from 0
For R = 0 To Day(DateAdd("m", 1, StartDay) - 2)
With WS.Cells(3 + R, 2)
.Value = StartDay + R
.NumberFormat = "d-mmm"
.Offset(, -1).Value = StartDay + R
.Offset(, -1).NumberFormat = "dddd"
End With
Next R
ReDim DayNames(1)
'To add more headers, change statement to 3
DayNames(0) = "Saturday"
DayNames(1) = "Sunday"
For b = LBound(DayNames) To UBound(DayNames)
Set Match = WS.Cells.Find(What:=DayNames(b), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious, _
MatchCase:=True, SearchFormat:=False)
If Not Match Is Nothing Then
FirstAddress = Match.Address
Do
Match.EntireRow.Clear
'Highlight cell containing table heading in green
Set Match = WS.Cells.FindNext(Match)
Loop While Not Match Is Nothing
End If
Next b
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Works for some reason if it's executed twice
Set DeleteDays = Range("A3:A50")
For Each c In DeleteDays
If c = "" Then
c.EntireRow.Delete
End If
Next c
'Insert and format template time values with formula for hours worked in E3
Set Day1 = Range("B3")
Range(Day1, Day1.End(xlDown)).Select
With Selection
Selection.Offset(, 1).Value = "8:00 AM"
Selection.Offset(, 1).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 2).Value = "4:00 PM"
Selection.Offset(, 2).NumberFormat = "h:mm AM/PM"
Selection.Offset(, 3).Value = "0"
Selection.Offset(, 3).NumberFormat = "h:mm"
Day1.Offset(, 3).Formula = "=D3-C3"
End With
'Fill in hours worked formula
Day1.Offset(, 3).Select
Selection.AutoFill Destination:=Range(Selection, Selection.End(xlDown))
'*This is the loop that isn't functioning, but also isn't calling any errors*
'Set Overtime calculation
Set WorkDays = Range("A3:A33")
For Each d In WorkDays
If d = "Friday" Then
d.Offset(, 6).Value = "0"
d.Offset(, 6).NumberFormat = "h:mm"
End If
Next d
End Sub
I've had some trouble with loops crashing Excel since I switched to Excel 365, but this For Each loop isn't crashing it. Any ideas as to why this For Each loop isn't doing its job?
I want to select a range (of values, the whole column) for the values: FirstDate, EndDate and Number. My VBA:
The Output of the below VBA is highlighted (Column D) :
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
FirstDate = Cells(1, 1).Value
EndDate = Cells(1, 2).Value
Number = Cells(1, 3).Value ' "Number" For the syntax DateAdd.
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Range("D1").Value = i - 1
End Sub
As I wrote before I want to run my Macro not only for the first 3 cells (currently the macro works fine for the value (1,1) (1,2) (1,3)), as you can see above for FirstDate, EndDate and Number
I want to use for all dates in Column1, Column2, Column3 for example:
I already tried this:
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Range("D1").Value = i - 1
Next
End With
End Sub
But is still transforming the 1 row.
If I'm understanding what you need correctly it's because you're calling out Range("D1").Value so it will always update that cell. You can make it more dynamic by using the lRow variable you already set up to place it into the correct row.
Replacing this Range("D1").Value = i - 1 with this Cells(lRow, 4).Value = i - 1
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Cells(lRow, 4).Value = i - 1
'Range("D1").Value = i - 1
Next
End With
End Sub
I'm trying to get a month from a cell that contains a date? I'm trying to do the following. But it throws a Run-time error #13 that the types don't match. How would you go about doing this, I've tried many solutions but it just doesn't work.
In my stylesheet I have this where I put start and end values and have blank spaces for the Macro to write in
Sub Search()
Dim accountTxt As String
Dim propertyTxt As String
Dim startMonth As Integer
Dim endMonth As Integer
Dim iAccount As String
Dim iProperty As String
Dim acum As Integer
Dim rowMonth As Integer
accountTxt = ActiveSheet.Cells(2, 17).Text
propertyTxt = ActiveSheet.Cells(3, 17).Text
startMonth = ActiveSheet.Cells(5, 17).Value
endMonth = ActiveSheet.Cells(6, 17).Value
For i = 1 To 800
iAccount = ActiveSheet.Cells(i, 8).Value
iProperty = ActiveSheet.Cells(i, 7).Value
rowMonth = Month(ActiveSheet.Cells(i, 1).Value)
If rowMonth >= startMonth And rowMonth <= endMonth Then
If InStr(1, iAccount, accountTxt) Then
Cells(i, 12).Interior.ColorIndex = 4
acum = acum + Cells(i, 12).Value
End If
End If
Next i
Cells(8, 17).Value = acum
End Sub
Say we have something in B9 like:
It may be a real date or just a string that looks like a date. In either case:
Sub PerhapsADate()
Dim s As String, MonthAsNumber As Long
Dim MonthAsString As String
s = Range("B9").Text
MonthAsNumber = --Split(s, "/")(0)
MonthAsString = Format(CDate(s), "mmmm")
MsgBox MonthAsNumber & vbCrLf & MonthAsString
End Sub
will get the month as both a number or a string:
To parlay off of Gary's Student's answer:
Sub PerhapsADate()
Dim s As Date, MonthAsNumber As Long
Dim MonthAsString As String
s = Range("B9").Text
MonthAsNumber = DatePart("m", s)
MonthAsString = Format(s, "mmmm")
MsgBox MonthAsNumber & vbCrLf & MonthAsString
End Sub
This solution differs slightly in that typing "s" as a date forces the text to be recognized as a date and therefore will be less prone to failure where international date format standards vary.
I got a type mismatch because the iterator starts reading the Date column at the "Date" heading and not the date value (e.g. 01-10-2017)
I'm trying to create a search that will display the information on the list box.
I'm trying to search by name and date range, or by name, or by date only.
I have code, the date is correct but it displays all the names.
Private Sub cmdFind_Click()
Dim DateRange As Range, rCl As Range, rng As Range, Dn As Range
Dim Date1 As Date, Date2 As Date
Dim iX As Integer
Dim strName As String
Set DateRange = Sheet2.Range("A1").CurrentRegion.Columns(4)
Set rng = Sheet2.Range("A1").CurrentRegion.Columns(4)
Me.ListBox1.Clear
strName = Me.txtName.Text
Date1 = CDate(Me.txtDate.Value)
Date2 = CDate(Me.EndDate.Value)
For Each rCl In DateRange.Cells
For Each Dn In rng.Cells
If rCl.Value >= Date1 And rCl.Value <= Date2 And strName Then
ElseIf Dn.Value = strName Then
With Me.ListBox1
.AddItem Sheet2.Cells(rCl.Row, 1)
.List(.ListCount - 1, 1) = Sheet2.Cells(rCl.Row, 2)
.List(.ListCount - 1, 2) = Sheet2.Cells(rCl.Row, 3)
.List(.ListCount - 1, 3) = Sheet2.Cells(rCl.Row, 4)
.List(.ListCount - 1, 4) = Sheet2.Cells(rCl.Row, 5)
.List(.ListCount - 1, 5) = Format(Sheet2.Cells(rCl.Row, 6), "hh:mm:ss")
End With
End If
Next Dn
Next rCl
End Sub
Assuming that you are checking the date range only in the same line: Delete the second loop For Each Dn in rng.Cells as well as Next Dn) and replace the following condition with:
If (rCl.Value >= Date1 And rCl.Value <= Date2) And rCl.Offset(0, -3).Value = strName Then
BTW, it's the better method to use arrays than range loops.