Extend deadline for today's dates-CodePudding

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

CodePudding user response：

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))

CodePudding user response：

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