A
AC
Hello,
I have a spreadsheet that tracks scheduled and completed dates for
some tasks. These tasks are color formatted based on how the scheduled
dates relate to Today() or if the task has been completed. Since I
have more than three conditions (Excel 2003) I am applying the
conditional formatting with a Worksheet_Change Event. This wipes out
the Undo function.
Using John Walkenbach's code to 'Undo a VBA subroutine', I get a run-
time error '10' when I select Edit-->Undo. Below are my code pieces.
Can anybody help, please? Any suggestions/solutions are greatly
appreciated.
Thanks so much.
Regards,
A. Crawford
=============================
Conditional Formatting
=============================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer
If Not Intersect(Target, Range("C3:I50")) Is Nothing Then
Select Case Target.Column
Case 3
If Target.Offset(0, 5).Value <> Empty Then
icolor = 34
ElseIf Target.Offset(0, 5).Value = Empty Then
If Target < Date Then
icolor = 3
ElseIf Target >= Date And Target <= Date + 7 Then
icolor = 4
ElseIf Target >= Date And Target >= Date + 7 And
Target <= Date + 14 Then
icolor = 27
Else
icolor = xlcolornone
End If
End If
Range(Target.Address, Target.Offset(0,
6).Address).Interior.ColorIndex = icolor
Case 8
If Target <> Empty Then
icolor = 34
ElseIf Target = Empty Then
If Target < Date Then
icolor = 3
ElseIf Target >= Date And Target <= Date + 7 Then
icolor = 4
ElseIf Target >= Date And Target >= Date + 7 And
Target <= Date + 14 Then
icolor = 27
Else
icolor = xlcolornone
End If
End If
Range(Target.Offset(0, 1).Address, Target.Offset(0,
-5).Address).Interior.ColorIndex = icolor
End Select
End If
Call Module1.Memo
End Sub
===========================
Undo modules
===========================
Type SaveRange
Val As Variant
Addr As String
End Type
Public OldWorkbook As Workbook
Public OldSheet As Worksheet
Public OldSelection() As SaveRange
Sub Memo()
If TypeName(Selection) <> "Range" Then Exit Sub
ReDim OldSelection(Selection.Count)
Set OldWorkbook = ActiveWorkbook
Set OldSheet = ActiveSheet
i = 0
For Each cell In Selection
i = i + 1
OldSelection(i).Addr = cell.Address
OldSelection(i).Val = cell.Formula
Next cell
Application.ScreenUpdating = False
Application.OnUndo "undo", "UndoZero"
End Sub
Sub UndoZero()
On Error GoTo Problem
Application.ScreenUpdating = False
OldWorkbook.Activate
OldSheet.Activate
For i = 1 To UBound(OldSelection)
Range(OldSelection(i).Addr).Formula = OldSelection(i).Val
Next i
Exit Sub
Problem:
MsgBox "Can't undo."
End Sub
I have a spreadsheet that tracks scheduled and completed dates for
some tasks. These tasks are color formatted based on how the scheduled
dates relate to Today() or if the task has been completed. Since I
have more than three conditions (Excel 2003) I am applying the
conditional formatting with a Worksheet_Change Event. This wipes out
the Undo function.
Using John Walkenbach's code to 'Undo a VBA subroutine', I get a run-
time error '10' when I select Edit-->Undo. Below are my code pieces.
Can anybody help, please? Any suggestions/solutions are greatly
appreciated.
Thanks so much.
Regards,
A. Crawford
=============================
Conditional Formatting
=============================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim icolor As Integer
If Not Intersect(Target, Range("C3:I50")) Is Nothing Then
Select Case Target.Column
Case 3
If Target.Offset(0, 5).Value <> Empty Then
icolor = 34
ElseIf Target.Offset(0, 5).Value = Empty Then
If Target < Date Then
icolor = 3
ElseIf Target >= Date And Target <= Date + 7 Then
icolor = 4
ElseIf Target >= Date And Target >= Date + 7 And
Target <= Date + 14 Then
icolor = 27
Else
icolor = xlcolornone
End If
End If
Range(Target.Address, Target.Offset(0,
6).Address).Interior.ColorIndex = icolor
Case 8
If Target <> Empty Then
icolor = 34
ElseIf Target = Empty Then
If Target < Date Then
icolor = 3
ElseIf Target >= Date And Target <= Date + 7 Then
icolor = 4
ElseIf Target >= Date And Target >= Date + 7 And
Target <= Date + 14 Then
icolor = 27
Else
icolor = xlcolornone
End If
End If
Range(Target.Offset(0, 1).Address, Target.Offset(0,
-5).Address).Interior.ColorIndex = icolor
End Select
End If
Call Module1.Memo
End Sub
===========================
Undo modules
===========================
Type SaveRange
Val As Variant
Addr As String
End Type
Public OldWorkbook As Workbook
Public OldSheet As Worksheet
Public OldSelection() As SaveRange
Sub Memo()
If TypeName(Selection) <> "Range" Then Exit Sub
ReDim OldSelection(Selection.Count)
Set OldWorkbook = ActiveWorkbook
Set OldSheet = ActiveSheet
i = 0
For Each cell In Selection
i = i + 1
OldSelection(i).Addr = cell.Address
OldSelection(i).Val = cell.Formula
Next cell
Application.ScreenUpdating = False
Application.OnUndo "undo", "UndoZero"
End Sub
Sub UndoZero()
On Error GoTo Problem
Application.ScreenUpdating = False
OldWorkbook.Activate
OldSheet.Activate
For i = 1 To UBound(OldSelection)
Range(OldSelection(i).Addr).Formula = OldSelection(i).Val
Next i
Exit Sub
Problem:
MsgBox "Can't undo."
End Sub