同行里，A列右侧保留的几个汉字，把A列里包含的这些字，设为红色

cqz2022

设置包含的字为红色.rar (7.8 KB, 下载次数: 6)

2024-2-17 13:27 上传

点击文件名下载附件

以下操作表格第1行都不参与

A列从A2起，记录一此要测试的内容，可能是词语、成语、古诗句

前提：①会按一定的规则，把A列的内容，填充到右侧，B列起单元格里，每个单元格一定只保留一个汉字
          ②会手动删除每A列右侧几个字，
完成手动删除后，求代码：

代码实现：
             每一行中，如果A列，包含了B列及B列右侧的汉字，则在A列中把这些字设为红色
             如果某行，只有A列有内容，则把这一行，整行删除
如图


谢谢

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, k&, r&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Range("A1", ActiveSheet.UsedRange)
        ar = .Value
        .Offset(1).Clear: r = 1
        For i = 2 To UBound(ar)
            dic.RemoveAll
            For j = 2 To UBound(ar, 2)
                If Len(ar(i, j)) Then dic(ar(i, j)) = Empty
            Next j
            If dic.Count > 1 Then
                r = r + 1
                For j = 1 To UBound(ar, 2)
                    .Cells(r, j) = ar(i, j)
                    With .Cells(r, 1)
                        For k = 1 To Len(.Value)
                            If dic.exists(Mid(.Value, k, 1)) Then
                                .Characters(Start:=k, Length:=1).Font.Color = vbRed
                            End If
                        Next k
                    End With
                Next j
            End If
        Next i
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

limonet

关键字：len+join

limonet

Sub limonet()
    Dim i%, Rng As Range
    For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Len(Join(Application.Transpose(Application.Transpose(Cells(i, "A").Offset(, 1).Resize(1, 4))))) = 3 Then
            Rows(i).Delete
        Else
            For Each Rng In Cells(i, "A").Offset(, 1).Resize(1, 4)
                Cells(i, "A").Characters(InStr(Cells(i, "A"), Rng), 1).Font.Color = vbRed
            Next
        End If
    Next i
End Sub

cqz2022

limonet 发表于 2024-2-17 14:54
关键字：len+join

只对单行 生效 红字跨行了

limonet

cqz2022 发表于 2024-2-17 15:42
只对单行 生效 红字跨行了

把
Cells(i, "A").Characters(InStr(Cells(i, "A"), Rng), 1).Font.Color = vbRed
换
If Rng <> "" Then Cells(i, "A").Characters(InStr(Cells(i, "A"), Rng), 1).Font.Color = vbRed

cqz2022

gwjkkkkk 发表于 2024-2-17 14:04
请参考。。。

测试成功  感谢

感谢limonet

ykcbf1100

参与一下。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.17
   
2.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
3.     Me.Cells.Font.ColorIndex = 0
   
4.     For i = r To 2 Step -1
   
5.         st = Me.Cells(i, 1)
   
6.         tem = ""
   
7.         For j = 2 To 5
   
8.             If Me.Cells(i, j) <> Empty Then
   
9.                 tem = tem & Me.Cells(i, j)
   
10.             End If
    
11.         Next
    
12.         If tem = Empty Then
    
13.             Me.Rows(i).Delete
    
14.         Else
    
15.             For x = 1 To Len(st)
    
16.                 If InStr(tem, Mid(st, x, 1)) Then
    
17.                     Me.Cells(i, 1).Characters(x, l).Font.ColorIndex = 3
    
18.                 Else
    
19.                     Me.Cells(i, 1).Characters(x, l).Font.ColorIndex = 0
    
20.                 End If
    
21.             Next
    
22.         End If
    
23.     Next
    
24. End Sub
    
25. 
    
26. 
    

复制代码