Excel VBA - 如何从列中的每个单元格中删除某种颜色的文本

Question

编辑：现在它的工作好多了，但是代码也开始从其他列中删除非黑色文本？_？ 该代码适用于其他工作表，所以我不确定为什么它只不适用于这个... :"( 请帮助

我有一个 excel 表，其文本在同一单元格中有多个 colors，例如同一单元格中的蓝色和黑色单词。 我想删除所有的蓝色单词。 我写了一个循环，循环遍历整个列中的单元格和单元格中的每个字符，并将黑色单词写回每个单元格。 但是，这需要很长时间，因此不太可行。 我也尝试使用 arrays 但我不确定如何将格式与值一起存储到数组中：“（谢谢！

Sub deletecommentsRight_New()

    Dim lrow As Long
    Dim textOut As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lrow = LastRow()
    Range("M1:M" & lrow).Select
    
    For Each Cell In Selection
        textOut = ""
        For i = 1 To Len(Cell)
            If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
                textOut = textOut & Mid(Cell, i, 1)
            End If
        Next
        Cell.Value = textOut
        Cell.Font.ColorIndex = 1
    Next Cell
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Public Function LastRow() As Long
'Finds the last non-blank cell on a sheet/range.

Dim lrow As Long
Dim lCol As Long
    
    lrow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
    
    LastRow = lrow

End Function

Answer 1

您正在为超过一百万个单元格执行此操作，其中大多数是空的。 如果您首先检查单元格是否为空，则可能会大大提高性能。

Answer 2

基于提供的建议，这里是修改后的代码。 由于原始代码用于选择，因此选择要求用户 select 范围的选项比定义固定范围要好。

Sub deletecomments()

    Dim textOut As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    '----------------------------
    Dim myrange As Range
    ThisWorkbook.Sheets("Sheet1").Activate   'Change Workbook and Sheet name accordingly
    Set myrange = Application.InputBox(Title:="Range Selector", Prompt:="Please select your Range.", Type:=8)
    '--------------------------

    For Each Cell In myrange  'Replace selection with myRange
        textOut = ""
        For i = 1 To Len(Cell)
            If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
                textOut = textOut & Mid(Cell, i, 1)
            End If
        Next
        Cell.value = textOut
        Cell.Font.ColorIndex = 1
    Next Cell
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Answer 3

首先，您应该始终在模块顶部使用Option Explicit ，以便它强制您正确声明所有变量。

无需遍历整个列。 仅循环通过实际具有值的单元格。 为此，我们可以使用Worksheet.UsedRange属性并与所需范围进行Intersect 。

此外，代码应该能够忽略错误和数字，因为您只对文本感兴趣。

此外，无需多次读取单元格值，因此最好使用数组仅读取一次。 With结构可以帮助轻松阅读单元格字体 colors。

这是我想出的-保留原始方法名称：

Option Explicit

Public Sub DeleteComments(ByVal rng As Range)
    Dim tempRng As Range
    Dim tempArea As Range
    
    Set tempRng = GetUsedRange(rng)
    If tempRng Is Nothing Then Exit Sub
    
    'Store app state and turn off some features
    Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating
    Dim calcMode As XlCalculation: calcMode = Application.Calculation
    Dim evEnabled As Boolean: evEnabled = Application.EnableEvents
    With Application
        If .ScreenUpdating Then .ScreenUpdating = False
        If calcMode <> xlCalculationManual Then .Calculation = xlCalculationManual
        If .EnableEvents Then .EnableEvents = False
    End With
    
    'Loop through all areas. Check/update only relevant values
    For Each tempArea In tempRng.Areas
        If tempArea.Count = 1 Then
            UpdateCell tempArea, tempArea.Value2
        Else
            Dim arr() As Variant: arr = tempArea.Value2 'Read whole range into array
            Dim rowsCount As Long: rowsCount = tempArea.Rows.Count
            Dim i As Long: i = 1
            Dim j As Long: j = 1
            Dim v As Variant
            
            'For Each... loop is faster than using 2 For... Next loops on a 2D array
            For Each v In arr 'Column-major order
                If VarType(v) = vbString Then 'Only check strings - ignore numbers and errors
                    If Len(v) > 0 Then UpdateCell tempArea.Cells(i, j), v
                End If
                i = i + 1
                If i > rowsCount Then 'Switch to the next column
                    j = j + 1
                    i = 1
                End If
            Next v
        End If
    Next tempArea

    'Restore app state
    With Application
        If scrUpdate Then .ScreenUpdating = True
        If calcMode <> xlCalculationManual Then .Calculation = calcMode
        If evEnabled Then .EnableEvents = True
    End With
End Sub

Private Function GetUsedRange(ByVal rng As Range) As Range
    If rng Is Nothing Then Exit Function
    On Error Resume Next
    Set GetUsedRange = Intersect(rng, rng.Worksheet.UsedRange)
    On Error GoTo 0
End Function

Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
    Dim textOut As String
    Dim charExcluded As Boolean
    Dim i As Long

    For i = 1 To Len(value)
        With cell.Characters(i, 1).Font
            If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
                textOut = textOut & Mid$(value, i, 1)
            Else
                charExcluded = True
            End If
        End With
    Next i
    If charExcluded Then cell.Value2 = textOut
    If IsNull(cell.Font.ColorIndex) Then
        cell.Font.ColorIndex = 1
    ElseIf cell.Font.ColorIndex <> 1 Then
        cell.Font.ColorIndex = 1
    End If
End Function

如您所见，我将代码拆分为几个辅助函数，以便于维护。

要使用它，只需在所需范围内调用它。 例如：

DeleteComments Selection 'if you already have a selected range
'Or
DeleteComments Range("M:M") 'as in your original post

另一个好处是，无论您想要的范围是一列、一行、多列/行还是多区域范围，此代码都有效。 为您提供很大的灵活性，并且尽可能快地完成。

编辑#1

如果我们只检查混合 colors 的单元格， UpdateCell function 可能会更快：

Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
    Dim textOut As String
    Dim charExcluded As Boolean
    Dim i As Long

    If IsNull(cell.Font.ColorIndex) Then
        For i = 1 To Len(value)
            With cell.Characters(i, 1).Font
                If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
                    textOut = textOut & Mid$(value, i, 1)
                Else
                    charExcluded = True
                End If
            End With
        Next i
        If charExcluded Then cell.Value2 = textOut
        cell.Font.ColorIndex = 1
    ElseIf cell.Font.ColorIndex <> 1 Then
        cell.Value2 = Empty
        cell.Font.ColorIndex = 1
    End If
End Function