0

I use the following VBA to extend the deadline of over-due (due today) tasks in the end of the day. However, I realized that applying the script twice (I linked the script to a button, which I accidentally pressed twice) results in all task-dates (and also the tasks with no date assigned) to be repalaced by tomorrow's date or get a date (next day).

How can I avoid this unwanted behavior? It seems the selection process of the dates to be changed is distored when applying the script twice.

Sub To_Do_Add_Day_Deadline()
'
' To_Do_Add_Day_Deadline Makro
'

'
    Range("C2").Select
    ActiveSheet.ListObjects("Tabelle113").Range.AutoFilter Field:=3, Criteria1 _
        :=xlFilterToday, Operator:=xlFilterDynamic
    Range("C4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "=TODAY()+1"
    Range("C4").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("E6").Select
    ActiveSheet.ListObjects("Tabelle113").Range.AutoFilter Field:=3
    Range("C4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E5").Select
End Sub
Fabian
  • 103
  • 6

2 Answers2

0

I replace Range("C4") with Range("C2"), because when you apply a filter, the table constraint their rows, and ever start at the next line after the header Range(""). I test this in a Table with a Range("A1:E25") with a header.

Sub To_Do_Add_Day_Deadline()
   Range("C2").Select
   ActiveSheet.ListObjects("Tabelle113").Range.AutoFilter Field:=3, Criteria1 _
   :=xlFilterToday, Operator:=xlFilterDynamic
   Range("C4").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection = CDate(Left(CDate(Now) + 1, 10))
   Application.CutCopyMode = False
   Range("E6").Select
   ActiveSheet.ListObjects("Tabelle113").Range.AutoFilter Field:=3
End Sub

Edit: I reduce the code and replace "=TODAY()+1" with CDate(Left(CDate(Now) + 1, 10))

Bphantom
  • 1
  • 1
  • Thanks @Bphantom, I should have mentioned that my table headers start in row 3, so I guess my code is identical to yours, right? – Fabian May 20 '22 at 16:06
  • Yes, the codes are identical and both replace the cells with Criteria1:=xlFilterToday by ActiveCell.FormulaR1C1 = "=TODAY()+1", but i find a method for change that with a VBA formula and i get the same result, but with a cell without the formula "=TODAY()+1", just change "=TODAY()+1" for **Left(CDate(Now) + 1, 10)** – Bphantom May 20 '22 at 16:36
0

I changed the approach and now use the following code, which works fine:

Sub On_Hold_Add_One_Day()
'
' On_Hold_Add_One_Day
'

'
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "=IF([@Deadline]=TODAY(),[@Deadline]+1,[@Deadline])"
    Range("E4").Select
    ActiveWindow.SmallScroll Down:=-9
    Range("E4").Select
    ActiveWindow.SmallScroll Down:=0
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-36
    Range("C4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=-9
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Cells.Select
    Selection.Rows.AutoFit
    Range("E6").Select
End Sub
Fabian
  • 103
  • 6