Gregor y
Gregor y

Reputation: 2050

How to use Range.ClearContents() within a Application.Evaluate() context in Excel2010

The ClearContents() method appears to be broken inside an Evaluate() context

minimal testing example

Dim ForceRunOnceTogg As Boolean

Public Sub cc_test()
    Dim s As Range: Set s = Selection.Cells(1)
    
    ForceRunOnceTogg = False
    Evaluate Replace("cc(%1)", "%1", s.Address)
End Sub

Private Function cc(c As Range)
    If ForceRunOnceTogg Then Exit Function
    ForceRunOnceTogg = True 'also not sure why eval double fires
    
    Debug.Print "marco" 'show double vs single eval fire
    c.Value = "bananas" 'show it has correct cell
    c.Interior.ColorIndex = 6 'Yellow
    c.AddComment "a comment" 'show can run methods on cell
    c.ClearContents ' this specific method doesn't fire?
End Function

I have tried various options to get ClearContents to fire inside the Evaluate, including just passing the address as a string and using set c = Application.Range(addr); however I have yet to find an option where ClearContents is working. Is there maybe a way to workaround ClearContents and still leave the cell in the same state as if it were cleared?

Otherwise, I guess I'm looking at a replacement for Evaluate in my usage case

minimal usage example

Dim ForceRunOnceTogg As Boolean

Private Sub MapSelection(Lambda As String)
    Dim r As Range, ar As Range, col As Range
    Set r = Selection
    
    Dim i As Long, rowCount As Long, FirstRow As Long, func As String
    
    Dim scrn As Boolean: scrn = Application.ScreenUpdating: Application.ScreenUpdating = False
    Dim calc As XlCalculation: calc = Application.Calculation: Application.Calculation = xlCalculationManual
    On Error GoTo RestApp
    
    For Each ar In r.Areas
        rowCount = ar.Columns(1).Cells.count
        FirstRow = ar.Cells(1).Row - 1
        For Each col In ar.Columns
            For i = 1 To rowCount
                If IsEmpty(col.Cells(i)) Then i = col.Cells(i).End(xlDown).Row - FirstRow
                If i > rowCount Then Exit For
                ForceRunOnceTogg = False
                func = Replace(Lambda, "%1", col.Cells(i).Address(External:=False))
'                Debug.Print func
                Application.Evaluate func
            Next i
        Next col
    Next ar
    Application.Calculation = calc: Application.Calculate
    Application.ScreenUpdating = scrn
    On Error GoTo 0
    Exit Sub

RestApp:
    Application.Calculation = calc: Application.Calculate
    Application.ScreenUpdating = scrn
    On Error GoTo 0
    Resume
End Sub

Private Function clearJunk_cell(c As Range)
    If ForceRunOnceTogg Then Exit Function
    ForceRunOnceTogg = True
    
    If IsError(c.Value) Then
        c.ClearContents ' ClearContents won't fire in this context
    ElseIf c.Value = "" Then
        c.ClearContents
    ElseIf Strings.Trim(c.Value) = "" Then
        c.ClearContents
    End If
End Function

Private Function markJunk_cell(c As Range)
    If ForceRunOnceTogg Then Exit Function
    ForceRunOnceTogg = True
    
    If IsError(c.Value) Then
        c.Interior.Color = 16776960 'Bright Blue
    ElseIf c.Value = "" Then
        c.Interior.Color = 16776960
    ElseIf Strings.Trim(c.Value) = "" Then
        c.Interior.Color = 16776960
    End If
End Function

Public Function ScrubText(text As String) As String
    Dim i As Long, T As String, a As Long
    For i = 1 To Len(text)
        T = Mid(text, i, 1)
        a = AscW(T)
        If 31 < a And a < 128 Then ScrubText = ScrubText & T
    Next i
End Function

Private Function Scrub_cell(c As Range)
    If ForceRunOnceTogg Then Exit Function
    ForceRunOnceTogg = True

    c.Value2 = ScrubText(c.Value2)
End Function

Private Function markScrub_cell(c As Range)
    If ForceRunOnceTogg Then Exit Function
    ForceRunOnceTogg = True

    If c.Value2 <> ScrubText(c.Value2) Then
        c.Interior.Color = 16776960 'Bright Blue
    End If
End Function

Public Sub clearJunk(): MapSelection "clearJunk_cell(%1)": End Sub
Public Sub markJunk(): MapSelection "markJunk_cell(%1)": End Sub

Public Sub scrubSelection(): MapSelection "Scrub_cell(%1)": End Sub
Public Sub markScrubSelection(): MapSelection "markScrub_cell(%1)": End Sub

Where clearJunk(), markJunk(), scrubSelection(), and markScrubSelection() along with other similar subs are called from ribbon buttons.

Upvotes: 0

Views: 48

Answers (1)

Gregor y
Gregor y

Reputation: 2050

Thanks to the comments, it turns out that Application.Run() made for a much cleaner solution.

Enum SpeedSetting: Fastest: Fast: Medium: Slow: End Enum

Public Sub SetSpeedUp(Optional Speed As SpeedSetting = Slow)
    Select Case Speed
     Case Fastest
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.DisplayStatusBar = False
        Application.Calculation = xlCalculationManual
        ActiveSheet.DisplayPageBreaks = False
     Case Fast
        Application.ScreenUpdating = False
        Application.EnableEvents = True
        Application.DisplayStatusBar = True
        Application.Calculation = xlCalculationManual
        ActiveSheet.DisplayPageBreaks = False
     Case Medium
        Application.ScreenUpdating = False
        Application.EnableEvents = True
        Application.DisplayStatusBar = True
        Application.Calculation = xlCalculationAutomatic
        ActiveSheet.DisplayPageBreaks = False
     Case Else 'Slow
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.DisplayStatusBar = True
        Application.Calculation = xlCalculationAutomatic
        ActiveSheet.DisplayPageBreaks = False
    End Select
End Sub

Private Sub Map(CellMacro As String, ApplyToRange As Range, Optional Speed As SpeedSetting = Fastest)
    Dim ar As Range, col As Range
    Dim i As Long, rowCount As Long, FirstRow As Long, MaxRow As Long
    
    SetSpeedUp Speed
    On Error GoTo RestApp
    
    For Each ar In ApplyToRange.Areas
        rowCount = ar.Columns(1).Cells.Count
        FirstRow = ar.Cells(1).Row - 1
        MaxRow = ar.Cells(1).EntireColumn.Cells.count
        For Each col In ar.Columns
            For i = 1 To rowCount
                If IsEmpty(col.Cells(i)) Then i = col.Cells(i).End(xlDown).Row - FirstRow
                If i > rowCount Then
                    Exit For
                ElseIf i = MaxRow Then
                    If IsEmpty(col.Cells(i)) Then Exit For
                End If
                Application.Run CellMacro, col.Cells(i)
            Next i
        Next col
    Next ar
    SetSpeedUp Slow
    On Error GoTo 0
    Exit Sub

RestApp:
    SetSpeedUp Slow
    On Error GoTo 0
    Resume
End Sub

Public Sub clearJunk(): Map "clearJunk_cell", Selection: End Sub
Private Sub clearJunk_cell(c As Range)
    If IsError(c.Value) Then
        c.ClearContents
    ElseIf c.Value = "" Then
        c.ClearContents
    ElseIf Strings.Trim(c.Value) = "" Then
        c.ClearContents
    End If
End Sub

Public Sub markJunk(): Map "markJunk_cell", Selection: End Sub
Private Sub markJunk_cell(c As Range)
    If IsError(c.Value) Then
        c.Interior.Color = 16776960 'Bright Blue
    ElseIf c.Value = "" Then
        c.Interior.Color = 16776960
    ElseIf Strings.Trim(c.Value) = "" Then
        c.Interior.Color = 16776960
    End If
End Sub

Public Sub Touch(): Map "touch_cell", Selection: End Sub
Private Sub touch_cell(c As Range)
    If Asc(c.Formula) <> 61 Then c.Value = c.Value
End Sub

Public Function ScrubText(text As String) As String
    Dim i As Long, T As String, a As Long
    For i = 1 To Len(text)
        T = Mid(text, i, 1)
        a = AscW(T)
        If 31 < a And a < 128 Then ScrubText = ScrubText & T
    Next i
End Function

Public Sub ScrubSelection(): Map "ScrubText_cell", Selection: End Sub
Private Sub ScrubText_cell(c As Range): c.Value2 = ScrubText(c.Value2): End Sub

Public Sub markScrubSelection(): Map "ScrubText_cell", Selection: End Sub
Private Function markScrub_cell(c As Range)
    If c.Value2 <> ScrubText(c.Value2) Then
        c.Interior.Color = 16776960 'Bright Blue
    End If
End Function

Upvotes: 1

Related Questions