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