提取A例标红的文字同时A例有包含B例的词根全部自动标红

吴虾咪

提取A例标红的文字同时A例有包含B例的词根全部自动标红.rar (63.56 KB, 下载次数: 7)

2024-8-18 12:31 上传

点击文件名下载附件

这下有老师弄的，词根在Sheet2，A例里面，不知道啥改成到本表B例里面来。


Sub 飘红()
Dim arr, s&, ss&, i&, j&
arr = Sheet2.Range("A1:A" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row) '   标红（Sheet2.Range）表格及位置
    With Sheet3
        For i = .Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
            For j = 1 To UBound(arr)
                s = InStr(1, .Cells(i, 1).Value, arr(j, 1))
                ss = InStr(s + Len(arr(j, 1)), .Cells(i, 1).Value, arr(j, 1))
                If s > 0 Then
                    With .Cells(i, 1).Characters(s, Len(arr(j, 1))).Font
                        .Color = vbRed
                        .Bold = True
                    End With
                End If
                If ss > 0 Then
                    With .Cells(i, 1).Characters(ss, Len(arr(j, 1))).Font
                        .Color = vbBlue
                        .Bold = True
                    End With
                End If
            Next
        Next
    End With
End Sub

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub 提取红色文字词根()
    Dim ws As Worksheet
    Set ws = ActiveSheet
      
    Dim cell As Range
    Dim targetColor As Long
    Dim i As Integer
    Dim char As String
    Dim coloredText As String
      
    ' 设置目标颜色为红色，使用RGB函数
    targetColor = RGB(255, 0, 0)
      
    ' 遍历A列的每个单元格
    For Each cell In ws.Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        coloredText = "" ' 初始化coloredText为空字符串
         
        ' 遍历单元格中的每个字符
        For i = 1 To Len(cell.Value)
            char = Mid(cell.Value, i, 1)
              
            ' 检查字符的颜色是否为红色
            If cell.Characters(i, 1).Font.Color = targetColor Then
                coloredText = coloredText & char
            End If
        Next i
         
        ' 将提取的有颜色的文字放置到B列的对应单元格中
        cell.Offset(0, 1).Value = coloredText
    Next cell
   
    Set d = CreateObject("scripting.dictionary")
    For Each cell In ws.Range("b3:b" & ws.Cells(ws.Rows.Count, "b").End(xlUp).Row)
        If Len(cell.Value) <> 0 Then d(cell.Value) = ""
    Next
    Key = d.keys
    For Each cell In ws.Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        ' 遍历单元格中的每个字符
        For i = 0 To UBound(Key)
            x = InStr(cell.Value, Key(i))
            If x Then
                cell.Characters(x, Len(Key(i))).Font.Color = targetColor
            End If
        Next i
    Next cell

End Sub

吴虾咪

quqiyuan 发表于 2024-8-18 16:00
参与一下，仅供参考。。。

谢谢老师的帮助。

吴虾咪

quqiyuan 发表于 2024-8-18 16:00
代码如下。。。
Sub 提取红色文字词根()
    Dim ws As Worksheet

老师，像删除颜色行，他是删一行的，有没有办法就删标红的格，不删行，删行就把提取后的词根格一起给删掉了。

quqiyuan

吴虾咪 发表于 2024-8-18 16:42
老师，像删除颜色行，他是删一行的，有没有办法就删标红的格，不删行，删行就把提取后的词根格一起给删掉 ...

删除单元格内容，还是删除单元格，然后下面的单元格往上？

吴虾咪

quqiyuan 发表于 2024-8-18 17:23
删除单元格内容，还是删除单元格，然后下面的单元格往上？

含有标红的单元格。是的往上

quqiyuan

吴虾咪 发表于 2024-8-18 17:40
含有标红的单元格。是的往上

供你参考。。。

quqiyuan

代码如下。。。
Sub 删除颜色单元格()
    Dim i&
    Dim Rng As Range
    With Sheet3
    For i = .Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
        For j = 1 To Len(.Cells(i, 1).Value)
            char = Mid(.Cells(i, 1).Value, j, 1)
              
            ' 检查字符的颜色是否为红色
            If .Cells(i, 1).Characters(j, 1).Font.Color <> 0 Then
                If Rng Is Nothing Then Set Rng = .Cells(i, 1) Else Set Rng = Union(Rng, .Cells(i, 1))
            End If
        Next
    Next
    If Not Rng Is Nothing Then Rng.Delete (xlUp)
    End With
End Sub