I have created a VBA to automatically populate yesterday's date in a cell, but need assistance as how should get the date as 16th June(Friday) instead of 18th June(which is a Sunday) when I trigger it on Monday.
`If .Column <> 11 Or .Row < 1 Then Exit Sub
If .Value = "Select" Then
If .Offset(0, 1).Value = "" Then
.Offset(0, 1).NumberFormat = "mm/dd/yy"
.Offset(0, 1).Value = Now - 1
.Offset(0, 2).Value = Now - 1
.Offset(0, 2).NumberFormat = "mmm-yy" '<~~ mmm-yy
.Offset(0, 3).Value = GetMonthWeek(Now - 1)
End If'
I am not sure if there is any inbuilt method for that, but the following logic works:
Dim tempDate
tempDate = DateAdd("d", -1, Date) 'Today's date - 1
While Weekday(tempDate) = 1 Or Weekday(tempDate) = 7 'If tempDate is a Sunday or a Saturday, keep on subtracting one day until we get a weekday
tempDate = DateAdd("d", -1, tempDate)
Wend
Cells(1, 1).Value = tempDate
Try implementing this in your code and let me know if it works. :)
Worksheet functions can easily retrieve the previous Friday whether or not the current day is a Friday.
'last Friday regardless
=A2-WEEKDAY(A2, 16)
'last Friday unless a Friday
=A2-WEEKDAY(A2, 16)+(WEEKDAY(A2)=6)*7
WEEKDAY and boolean operations are directly transferable to VBA.
Related
I have a macro that filters data by each unique value in column A and then adds lines for any missing dates. The Macro will only add the missing dates for the start of the month to the first group. The rest of the missing dates are added to all groups without any issues.
I think the issue is the 'If I = 2 then prevcell = start_date'. Is there any way to fix this so each time the macro filters it adds the missing dates at the start of the group even when not in line 2?
'Sub Macro1()
Dim aNames As Variant, Itm As Variant
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AdvancedFilter Action:=xlFilterInPlace, Unique:=False
aNames = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlVisible).Value
For Each Itm In aNames
.AutoFilter Field:=1, Criteria1:=Itm
'Do whatever you want with an individual name here
Call Macro2
Next Itm
.AutoFilter
End With
Sub Macro2()
Dim wks As Worksheet, ssh As Worksheet
Set wks = Worksheets("NAV_REPORT_FSIGLOB1")
Set ssh = Worksheets("SUMMARY")
Dim lastRow As Long, start_date As Date, end_date As Date, curcell As Date
lastRow = wks.Range("D2").End(xlDown).Row
start_date = ssh.Range("A2") - 1
end_date = ssh.Range("B2")
With wks.Cells(lastRow, 4)
If .Value < end_date Then
.EntireRow.Copy
.EntireRow.Insert xlShiftDown
lastRow = lastRow + 1
.Value = end_date
End If
End With
For i = lastRow To 2 Step -1
curcell = wks.Cells(i, 4).Value
If i = lastRow Then curcell = end_date
prevcell = wks.Cells(i - 1, 4).Value
If i = 2 Then prevcell = start_date
Do Until curcell - 1 <= prevcell
wks.Rows(i).Copy
wks.Rows(i).Insert xlShiftDown
curcell = wks.Cells(i + 1, 4) - 1
wks.Cells(i, 4).Value = curcell
Loop
Next i`
The answer below assumes that all your three questions here, here and here is actually the same which have the same expected result.
I have a macro that filters data by each unique value in column A
The code below is not involving a unique value and a filtering.
The start and end date would need updated monthly so needs to be
easily changed e.g. cells A2 and B2 on the "Summary" worksheet.
The code will involve a start date (dtS) value and end date value (dtE).
adds lines for any missing dates
The row addition regarding the dtS will happen only if the first value in column D is bigger then dtS. If the first value in column D is smaller than the dtS then it does nothing
The row addition regarding the dtE will happen only if the last value in column D is smaller then dtE. If the last value in column D is bigger than the dtE then it does nothing.
before running the sub :
In a condition where dtS = "02-Oct-22": dtE = "20-Oct-22", If yellow column D value is 2 Oct 22, then no process is performed. If blue column D value is 23 Oct 22, then no process is performed.
The expected result :
yellow will be 2 rows, where column D value is from 2 to 3 Oct 22.
orange will be 3 rows, where column D value is from 8 to 10 Oct 22.
green will be 5 rows, where column D value is from 13 to 17 Oct 22.
blue will be 3 rows, where column D value is from 18 to 20 Oct 22.
There will be three section in the code.
The first is a loop which already mentioned in the answer of your question here.
The second and the third is additional code to involve the dtS and dtE.
Sub test()
Dim dtS As Date: Dim dtE As Date
Dim c As Range: Dim dif As Integer
Set c = Range("D2")
dtS = "02-Oct-22": dtE = "20-Oct-22"
'same code in https://stackoverflow.com/questions/75172779/vba-code-help-need-to-add-a-line-for-each-missing-date-and-copy-data-from-cell/75180868#75180868
Do While c.Offset(1, 0).Value <> ""
dif = DateDiff("d", c.Value, c.Offset(1, 0).Value)
If dif > 1 Then
With c.Offset(1, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 2, 0)).Insert Shift:=xlDown
End With
c.AutoFill Destination:=Range(c, c.Offset(dif - 1, 0)), Type:=xlFillDefault
Set c = c.Offset(dif, 0)
Else
Set c = c.Offset(1, 0)
End If
Loop
'check the dtS in column D first value
Set c = Range("D2")
If dtS < CDate(c.Value) Then
dif = DateDiff("d", dtS, c.Value): c.Value = dtS
With c.Offset(0, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 1, 0)).Insert Shift:=xlDown
End With
Set c = Range("D2")
c.AutoFill Destination:=c.Resize(dif + 1, 1), Type:=xlFillDefault
End If
'check the dtE in column D last value
Set c = Range("D2").End(xlDown)
If dtE > CDate(c.Value) Then
addr = c.Address: dif = DateDiff("d", c.Value, dtE)
With c.Offset(0, -3)
.EntireRow.Copy
Range(.Cells, .Offset(dif - 1, 0)).Insert Shift:=xlDown
End With
With Range(addr)
.AutoFill Destination:=.Resize(dif + 1, 1), Type:=xlFillDefault
End With
End If
End Sub
Again, the sub above is based on guessing from all of your three questions. Because in your first question, you don't mentioned about start date and end date at all. In the second question you mentioned :
Could someone help with rewriting the code so it adds all dates that
are missing between a start and end date. The start and end date would
need updated monthly so needs to be easily changed e.g. cells A2 and
B2 on the "Summary" worksheet
And in this question, you mentioned ONLY about the start date.
add the missing dates for the start of the month
Please note that the answer is based on the data in your second question, where your data is something like this
which your expected result is like this
i want to write a Vba for excel that allow me to write every 8 rows the date of the year starting from january 2023 till the end of december 2023 (format dd, mm, yyyy) excluding sunday of all the weeks.
If i want to reduce the distance of the only rows tha t separates saturday from monday how could i do?
attached an Example
Up to now i wrote this routine that writes every date of the year, but it does also consider sunday and the distance of 8 rows from saturday to monday that i would like to reduce to 3 rows as previously said.
Thanks
Sub Datesoftheyear()
Dim currentDate As Date
Dim endYear As Date
currentDate = Date
endYear = DateSerial(Year(Now()), 12, 31)
For i = 1 To X Step 8
Cells(i, 1).Value = Format(currentDate, "dd-mm-yyyy")
currentDate = DateAdd("d", 1, currentDate)
If currentDate > endYear Then Exit For
Next i
End Sub
You can determine if a date is Sunday using the Weekday function, or using the DatePart function with Interval:="w"
Then, in your loop, you can test for currentDate being a Sunday, and if it is, advance forward by one day.
Sub Datesoftheyear()
Dim currentDate As Date
Dim endYear As Date
currentDate = Date
endYear = DateSerial(Year(Now()), 12, 31)
For i = 1 To X Step 8
Cells(i, 1).Value = Format(currentDate, "dd-mm-yyyy")
currentDate = DateAdd("d", 1, currentDate)
'If sunday, advance to next day
If Weekday(currentDate) = vbSunday Then currentDate = DateAdd("d", 1, currentDate)
If currentDate > endYear Then Exit For
Next i
End Sub
You can use this code.
Offset is defined as constant at the beginning of the sub - like that you can change it without searching within the code.
I added an explicit activesheet.cells(1,1) - you maybe want to adjust that
I set the start date to the January 1st. of current year.
regarding the "Sunday"-check: you have to adapt that to your regional settings. For Germany, e.g. a week starts on monday and sundays weekday = 7 ...
Sub DatesOfTheYear()
'Define row offset between two dates here
Const rowOffset As Long = 3
Dim startDate As Date, endYear As Date, rowDate As Date
Dim i As Long, j As Long
startDate = DateSerial(Year(Now()), 1, 31)
endYear = DateSerial(Year(Now()), 12, 31)
Dim rg As Range
Set rg = ActiveSheet.Cells(1, 1)
For i = 0 To DateDiff("d", startDate , endYear)
rowDate = startDate + i
'!!!!
'!!! you have to check this for your country settings
'!!!!!
If Weekday(rowDate, vbMonday) <> 7 Then
rg.Offset(j * (rowOffset + 2)) = Format(rowDate, "ddd")
rg.Offset((j * (rowOffset + 2)) + 1) = rowDate
j = j + 1
End If
Next i
End Sub
Sub Datesoftheyear()
MyRow = 1
For idt=date To DateSerial(Year(date),12,31)
If mod(idt,7)<>1 Then
Cells(MyRow,1).Value = idt
MyRow = MyRow + 8
End If
Next idt
End Sub
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
I use the following code:
Sub SplitDateTime()
Dim dDate As Date
Dim dTime As Date
Dim x As Integer
MsgBox "Split Date Time"
For x = 2 To 21
'Sets the date in the cell of the first column
dDate = Cells(x, 2)
dTime = Cells(x, 2)
Cells(x, 2).Value = Format(dDate, "dd/mm/yyyy")
'Sets the time in the cell of the second column
Cells(x, 3).Value = Format(dTime, "hh:mm")
Next x
When this is run I get the following:
Notice that the 2nd to the 6th row of dates weren't converted properly. It seems that these rows were changed to mm/dd/yyyy instead of dd/mm/yyyy (they were originally 12/01/2019...), possibly because the conversion is inconsistent, and then the time was inserted as 00:00. Has anyone any suggestions on how to correct this?
This is the original:
Original columns, the first column was subsequently deleted
Something like the following should work:
Sub SplitDateTime()
Dim dDate As Date
Dim dTime As Date
Dim x As Integer
MsgBox "Split Date Time"
For x = 2 To 21
'Sets the date in the cell of the first column
dDate = Cells(x, 2)
With Cells(x, 2)
.Value = Int(dDate)
.NumberFormat = "dd/mm/yy"
End With
'Sets the time in the cell of the second column
With Cells(x, 3)
.Value = dDate - Int(dDate)
.NumberFormat = "hh:mm"
End With
Next x
End Sub
I have the following piece of code, which is excluding all results in excel sheet that have date different than today + 6 days.
The problem is that when I execute that on Monday I hit Sunday.
I need to change it in a way that it will add always 6 days to my current date unless the result is Saturday or Sunday, then I would like to take the first working day after that, meaning - Monday.
Public Sub GRP_SC_Filter1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim DelDate As Long
DelDate = DateSerial(Year(Date), Month(Date), Day(Date) + 6)
LR = Sheets("Goods Receivable Planning").Range("A" & Rows.Count).End(xlUp).Row
Cells.AutoFilter Field:=13, Criteria1:="<>" & DelDate
ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If ALR > 2 Then
Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).Select
Range("A2:A" & LR).Delete
Range("A1").Activate
End If
Cells.AutoFilter
' MsgBox "Finished deleting rows"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I would be really thankful if somebody could help me transforming this into what I need. I am honestly stuck. Thank you in advance!
This function should do what you want:
Function GetNextWorkingDay(dt As Date) As Date
Select Case Weekday(dt)
Case 1
GetNextWorkingDay = DateAdd("d", 1, dt)
Case 7
GetNextWorkingDay = DateAdd("d", 2, dt)
Case Else
GetNextWorkingDay = dt
End Select
End Function
The function weekDay can hep you. The second parameter defines what day return 1, vbMonday would say that Mondays are 1, Saturday = 6, Sunday = 7
So, one way would be:
deldate = DateSerial(Year(Date + 3), Month(Date + 3), Day(Date + 3) + 6)
Do While (Weekday(deldate, vbMonday) >= 6)
deldate = deldate + 1
Loop