删除指定颜色文字，设置字体颜色

cqz2022

例子.rar (10.45 KB, 下载次数: 10)

2023-2-9 17:07 上传

点击文件名下载附件

C2：C每个单元格里的蓝色字是用宏代码Font.ColorIndex = 5设置的，请教高手，怎样用宏代码，一次性把每个单元格里的蓝色字都删除，并把红色（Font.ColorIndex = 3）文字设置为自动。

谢谢

liulang0808

楼主发过帖子吧，上次不是已经给处理建议了吗？

liulang0808

Sub 按钮1_Click()

    Set d = CreateObject("scripting.dictionary")
    For j = 2 To Cells(Rows.Count, 3).End(3).Row
        arr = Split("；" & Cells(j, 3), "；")
        d.RemoveAll
        x = 1
        For i = 1 To UBound(arr)
            If Not d.exists(arr(i)) Then
                Set d(arr(i)) = CreateObject("scripting.dictionary")
            End If
            d(arr(i))(x) = x
            x = x + Len(arr(i)) + 1
        Next i
        For Each k In d.keys
            If d(k).Count > 1 Then
                 x = d(k).keys()(0)
                Cells(j, 3).Characters(x, Len(k)).Font.ColorIndex = 3
                For i = 1 To d(k).Count - 1
                    x = d(k).keys()(i)
                    Cells(j, 3).Characters(x, Len(k)).Font.ColorIndex = 8
                Next i
            End If
        Next k
        str1 = ""
        For i = 1 To UBound(arr)
            If d.exists(arr(i)) Then
                str1 = str1 & "；" & arr(i)
                d.Remove arr(i)
            End If
        Next i
        Cells(j, 3) = Mid(str1, 2)

        With Cells(j, 3).Font
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
        End With
    Next j


End Sub

liulang0808

附件内容供参考。。。。。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, Rng As Range, strTxt$
   
    Set Rng = Range("C1", Cells(Rows.Count, "C").End(3))
       With Rng
          ar = .Value
          For i = 2 To UBound(ar)
             strTxt = ar(i, 1)
             For j = Len(ar(i, 1)) To 1 Step -1
                If .Cells(i, 1).Characters(j, 1).Font.Color = vbBlue Then
                   Select Case j
                      Case j = Len(ar(i, 1))
                         strTxt = Left(strTxt, Len(strTxt) - 1)
                      Case j = 1
                         strTxt = Right(strTxt, Len(strTxt) - 1)
                      Case Else
                         strTxt = Left(strTxt, j - 1) & Right(strTxt, Len(strTxt) - j)
                   End Select
                End If
             Next j
             ar(i, 1) = strTxt
          Next i
          .Font.ColorIndex = 0
       End With
      
       [C1].Resize(UBound(ar)) = ar
       Beep
End Sub

gwjkkkkk

请参考。。。

准提部林

Sub TEST_A1()
Dim Arr, A As Range, T$, i&, j%
With Range([c2], [c65536].End(3)(2))
     Arr = .Value
     For Each A In .Cells
         For j = 1 To Len(A)
              If A.Characters(j, 1).Font.ColorIndex <> 5 Then T = T & Mid(A, j, 1)
         Next j
         i = i + 1: Arr(i, 1) = T: T = ""
     Next
     .Font.ColorIndex = 0
     .Value = Arr
End With
End Sub

cqz2022

liulang0808 发表于 2023-2-9 17:11
楼主发过帖子吧，上次不是已经给处理建议了吗？

辛苦了 有点笨 弄了好久 重复的也没有删除掉

cjc209

liulang0808 发表于 2023-2-9 17:21
Sub 按钮1_Click()

    Set d = CreateObject("scripting.dictionary")

老师写得太绕了 其实直接了当 简单明了 用不住那麽多代码
Sub 删除指定颜色的字符()
    Dim i, j, k, arr, brr, x, y
    Sheet1.Activate
    最大行 = Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To 最大行
        arr = Split(Cells(i, 3).Value, "；")
        strtxt = ""
        总长度 = 0
        起始位置 = 0
        For j = 0 To UBound(arr)
            字符长度 = Len(arr(j))
            总长度 = 总长度 + 字符长度 + 1 '+1是加上分割符号占据的位置
            起始位置 = 总长度 - 字符长度
            If Cells(i, 3).Characters(起始位置, 字符长度).Font.ColorIndex <> 5 Then
                strtxt = strtxt & "；" & arr(j)
            End If
        Next
        Cells(i, 3).Clear
        Cells(i, 3) = Mid(strtxt, 2)
    Next
End Sub

cjc209

准提部林 发表于 2023-2-9 21:22
Sub TEST_A1()
Dim Arr, A As Range, T$, i&, j%
With Range([c2], [c65536].End(3)(2))

你这样应该留下字体后面多余的分隔符号了 因为标点符号不是与前面字体颜色一样的颜色