I'm trying to use vba to replace last week's date with this week's to update figures. I've tried the below but I don't think I'm understanding how the replace function works in VBA.
Dim lastweek As String
lastweek = Format(Now - 7, "yyyymmdd")
Dim thisweek As String
thisweek = Format(Now, "yyyymmdd")
Replace (lastweek,lastweek,thisweek)
Also, am I using the correct formula for last week where I want to pull the date for 7 days ago?
Convert the last week to Date and add 7 days to it, to get next week value
Function MyWeek(lastweek As String) As String
lw = DateSerial(CInt(Left(lastweek, 4)), CInt(Mid(lastweek, 5, 2)), CInt(Right(lastweek, 2)))
MyWeek = Format(lw + 7, "yyyymmdd")
End Function
Then use,
=REPLACE(A1,SEARCH("2*]",A1,1),8,Myweek(MID(A1,SEARCH("2*]",A1,1),8)))
to replace the date with new date, assuming your string to be replaced is in the Cell A1
You can also use auto-filter option in VBA. Just paste the below code in a Module as follows:
Sub date_change()
Dim filter_column As Range
Dim start_date As Date
Dim end_date As Date
With ActiveSheet
.AutoFilterMode = False
Set filter_column = .Range("j1") 'give the column which has the date that needs to be changed
end_date = Now - Weekday(Now, vbSunday)
end_date = DateSerial(Year(end_date), Month(end_date), Day(end_date))
start_date = end_date - 6
start_date = DateSerial(Year(start_date), Month(start_date), Day(start_date))
.Rows(1).AutoFilter Field:=filter_column.Column, Criteria1:=">=" & start_date, Operator:=xlAnd, Criteria2:="<=" & end_date
.Range(.Cells(2, filter_column.Column), .Cells(.Rows.Count, filter_column.Column).End(xlUp)).Select
If WorksheetFunction.Subtotal(3, Selection) <> 1 Then
Selection.ClearContents
Selection = Now
End If
End With
End Sub
Related
Trying to build something that checks what day is today and then filters a pivot table based on this. If today is Monday then, the pivot needs to be filtered on the "Report date" of the last 3 days (Friday/Saturday/Sunday). If any other day, the "Report date" needs to be filtered on the previous day only.
If Weekday(Now(), vbMonday) = 1 Then
rDate = Format(Now() - 3, "dd/mm/yyyy")
Else: rDate = Format(Now() - 1, "dd/mm/yyyy")
End If
But I do not know how to use this variable to create the filter after.
Can anyone help?
Thanks!
Try the code below, explanations inside the code's comments:
Option Explicit
Sub FilterPivot()
Dim PvtTbl As PivotTable
Dim DateStart As Double, DateFinish As Double
Dim PvtFld As PivotField
Dim PvtItm As PivotItem
Application.ScreenUpdating = False
' set the Pivot-Table Object
' Modify "Sheet1" to where your Pivot-Table lies, and "PivotTable1" to your Pivot-Table name
Set PvtTbl = Worksheets("Sheet1").PivotTables("PivotTable1")
' set the Pivot Field Object
' Modify "Date" to the Pivot Field's name you want to filter
Set PvtFld = PvtTbl.PivotFields("Date")
If Weekday(Now(), vbMonday) = 1 Then
DateStart = DateAdd("d", -3, Date) ' the first date in the range of dates to display (current date -3 days)
Else
DateStart = DateAdd("d", -1, Date) ' the first date in the range of dates to display (current date -1 day)
End If
DateFinish = DateAdd("d", -1, Date) ' the last date in the range of dates to display (current date -1 day)
PvtFld.ClearAllFilters ' clear all existing filters
For Each PvtItm In PvtFld.PivotItems ' loop through items in PivotField
' check if the value of the date is between the scanned ranges of dates (1 day, or 3 days)
If CDbl(DateValue(PvtItm.Name)) >= DateStart And CDbl(DateValue(PvtItm.Name)) <= DateFinish Then
PvtItm.Visible = True
Else
PvtItm.Visible = False
End If
Next PvtItm
Application.ScreenUpdating = True
End Sub
I have a sheet that have a range of dates in column A. I already found the way to get the last row with:
LastRow = Worksheets("TIME").Cells(Rows.Count, "A").End(xlUp).Row
Now I am trying to get specific dates. The range contains no weekends, but since the dates are proprietary, I could not use the WorkDay function to find what I need.
Case 1:
From the last date available, I am trying to get the date 1 year before (if the date is not available, pick the next available one).
What I did here was to use the date function and subtract 1 year..
day1Y = date(year(LastRow)-1,month(LastRow),day(LastRow))
To match, I transformed the date range into an array, and used a function do determine if it is in the array. If it is, get it, but if it is not, I don't know how to get the next available.
Dim DateArray() as Variant
Dim WantedDate1 as date
Dim WantedDate2 as date
DateArray() = Worksheets("TIME").Range("A2:A" & LastRow).Value
If IsInArray(day1Y) = True then
WantedDate1 = .Cells(1,LastRow).Value
End if
Case 2:
From the last available date, I am trying to get the first date in the same year (if last date is 10/08/2015, it gets the first available date of 2015, according to the dates available in the range).
WantedDate2 = Year(.Cells(1,LastRow).Value)
I got the year of the last date, but again, I can't find the first date of that year.
Any help will be deeply appreciated.
Use a loop to increase the days 1 by 1 and test if it is the array on the go :
Option Explicit
Sub DGMS89()
Dim wsT As Worksheet
Dim LastRow As Double
Dim DateArray() As Variant
Dim LastDate As Date
Dim Day1y As Date
Dim WantedDate1 As Date
Dim WantedDate2 As Date
Set wsT = ThisWorkbook.Sheets("TIME")
LastRow = wsT.Cells(wsT.Rows.Count, "A").End(xlUp).Row
DateArray() = wsT.Range("A2:A" & LastRow).Value
LastDate = DateArray(UBound(DateArray, 1))
Day1y = DateAdd("yyyy", -1, LastDate)
WantedDate1 = Day1y
If IsInArray(WantedDate1) Then
Else
Do While Not IsInArray(WantedDate1)
WantedDate1 = DateAdd("d", 1, WantedDate1)
Loop
End If
WantedDate2 = DateSerial(year(LastDate), 1, 1)
Do While Not IsInArray(WantedDate2)
WantedDate2 = DateAdd("d", 1, WantedDate2)
Loop
End Sub
I have to add one month extra to the cell value date.
I have date in the cell i.e 201604. I need to add extra month to that date and have to use that data as a file name. example: sree 201605.xlsm
My code:
Sub vba()
Check_date = Worksheets("abc").Range("A2").Value
format_date = format(dateadd(check_date("m", 1), "yyyymm"))
end sub
can someone please answer me.
Consider:
Sub dural()
Dim n As Long, s As String, d As Date
n = Range("A1").Value
d = DateSerial(Left(n, 4), Right(n, 2) + 1, 1)
s = Format(d, "yyyymm") & ".xlsm"
MsgBox s
End Sub
I have a column of dates in Column D in the mm-dd-yyyy format. Below is the code that I am trying to use to delete the entire row of data if the Active Cell in Column D is either Blank, Today's Date, or older than 8 days (i.e. today is 3/13/14, so it would erase blank entries, today's date, and anything older than 3/5/14).
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Range("D" & lastrow).Select
Do
If (ActiveCell = "" Or ActiveCell = Format(Now, "mm/dd/yyyy") Or ActiveCell < Format(Now -8, "mm/dd/yyyy")) _
Then ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Loop Until ActiveCell = "Completed Date)"
If I use the "<" symbol, it erases everything basically, and if I use the ">" symbol, then it doesn't erase the rows with dates in February, etc. Can anyone suggest a method that will work, or why mine isn't?
I'm just thinking off the top of my head, but the moment you use the Format keyword in Excel, it probably converts the date to a text value, so you can't perform comparison operations on it...
Try this instead:
If (ActiveCell = "" Or (ActiveCell = Format(Now, "mm/dd/yyyy")) Or (Cdate(ActiveCell) < (Now -8))) _
In effect, rather than changing NOW()-8 to text, converting Activecell to a date you can use for comparison's sake.
Again, I didn't do this with VBA, but I'm guessing it should do the trick.
Good luck!!
Try use DateDiff:
If not isempty(activecell)
If DateDiff("d", Now(), ActiveCell.Value) < -8 then
'do your stuff
endif
endif
Paste the following code into a module:
Sub ScrubData()
Dim i As Long
Dim numRowsWithVal As Long
Dim myActiveCell As Range
Dim todaysDate As Date
Dim cutoffDate As Date
'Use a custom function to delete all blank rows in column specified
Call DeleteAllBlankRowsInColumn("D")
'Use VBA's Date() function to get current date (i.e. 3/13/14)
todaysDate = Date
'Set the cutoff date to anything older than 8 days
cutoffDate = todaysDate - 8
'***** Loop through all rows and clear values if rows are equal to today's date or older than 8 days ******
'Count the number of rows with values (subtract one because sheet has headers)
numRowsWithVal = (Range("D" & Rows.Count).End(xlUp).Row) - 1
'Start at Range("D2")
Set myActiveCell = ActiveSheet.Range("D2")
For i = 0 To numRowsWithVal - 1
Select Case True
'If value of cell is today's date OR older than 8 days clear the values
Case myActiveCell.Offset(i, 0).Value = todaysDate, myActiveCell.Offset(i, 0).Value <= cutoffDate
myActiveCell.Offset(i, 0).ClearContents
'Value is valid, do nothing
Case Else
End Select
Next
'***********************************************************************************************************
'Now that values are cleared, delete all blank rows again
Call DeleteAllBlankRowsInColumn("D")
End Sub
Public Function DeleteAllBlankRowsInColumn(ByVal columnLetter As String)
'Delete all blank rows in column specified (suppress errors just in case there aren't any blank cells)
On Error Resume Next
Columns(columnLetter).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
'Set error handling back to normal
On Error GoTo 0
End Function
Before:
After:
Trying to do an insert if formula in VBA for the following;
In my column K I want three conditions:
Date is Today or older (ie project is due today or earlier) = RED
Date is Today + up to 7 days = Amber
Date is Today less more than 7 days = Green
I was thinking of using something along the lines of:
Sub ChangeColor()
lRow = Range("K" & Rows.Count).End(xlUp).Row
Set MR = Range("K3:K" & lRow)
For Each cell In MR
If cell.Value = "TODAY" Then cell.Interior.ColorIndex = 10
If cell.Value = "TODAY-7days" Then cell.Interior.ColorIndex = 9
If cell.Value = "Morethan7Days" Then cell.Interior.ColorIndex = 8
Next
End Sub
I've been trying but I'm not sure how to do it.
I think my way is correct yet I am not sure how to code the If date=-7days then and so on.
Can someone provide some guidance? :)
VBA has a Date function that returns today's date. Dates in VBA are the number of days since December 31, 1900 (usually and with a leap year bug), so you can subtract or add integers to Date to get past and future days.
Sub ChangeColor()
Dim rCell As Range
With Sheet1
For Each rCell In .Range("K3", .Cells(.Rows.Count, 11).End(xlUp)).Cells
If rCell.Value <= Date Then
rCell.Interior.Color = vbRed
ElseIf rCell.Value <= Date + 7 Then
rCell.Interior.Color = vbYellow
Else
rCell.Interior.Color = vbGreen
End If
Next rCell
End With
End Sub
Mr. Anderson is correct that you could accomplish this with conditional formatting however if you want to do this in VBA Create a variable to hold the date and set it to the current day minus the time. Then you just want to Format the cells value to a date format. Once this is done you can use dateAdd to and and subtract the days. See below
Sub ChangeColor()
Dim myDate As Date
'format the date excluding time
myDate = FormatDateTime(Now, 2)
lRow = Range("K" & Rows.Count).End(xlUp).Row
Set MR = Range("K3:K" & lRow)
For Each cell In MR
If FormatDateTime(cell.Value, 2) = myDate Then cell.Interior.ColorIndex = 10
If FormatDateTime(cell.Value, 2) = DateAdd("d", -7, myDate) Then cell.Interior.ColorIndex = 9
If FormatDateTime(cell.Value, 2) = DateAdd("d", 7, myDate) Then cell.Interior.ColorIndex = 8
Next
End Sub
I did notice that your checking to see if it is equal so only dates that are exactly Todays date, 7 days from today and 7 days previous to today will have the interior color filled. greater than and less than to fill all interior cell colors
Sorry for all the edits