求助如何优化窗口输入区域选择自定义字数以上相同文字标红

legend127

求助如何优化窗口输入区域选择自定义字数以上相同文字标红，现处理A2：A150（150条）处理需要时间3个钟
窗口输入区域选择自定义字数以上相同文字标红.zip (19.31 KB, 下载次数: 2)

2024-12-15 19:45 上传

点击文件名下载附件

1. Sub 窗口输入区域选择自定义字数以上相同文字标红()
   
2.     Dim ws As Worksheet
   
3.     Dim cell As Range
   
4.     Dim cellText As String
   
5.     Dim i As Long, j As Long, k As Long
   
6.     Dim minSubstringLength As Long
   
7.     Dim foundMatch As Boolean
   
8.     Dim startMatch As Long
   
9.     Dim currentSubstring As String
   
10.     Dim inputValue As String
    
11.     Dim userRange As Range
    
12.    
    
13.     ' 设置最小子字符串长度的默认值或让用户输入
    
14.     inputValue = InputBox("请输入要查找的重复子字符串的最小长度（例如：5）：", "输入最小长度")
    
15.     If inputValue = vbNullString Then Exit Sub ' 用户点击了取消
    
16.     If Not IsNumeric(inputValue) Or CLng(inputValue) <= 0 Then
    
17.         MsgBox "请输入一个大于0的有效数字。", vbExclamation
    
18.         Exit Sub
    
19.     End If
    
20.     minSubstringLength = CLng(inputValue)
    
21.    
    
22.     ' 让用户选择范围
    
23.     On Error Resume Next
    
24.     Set userRange = Application.InputBox("请选择要处理的单元格范围：", "选择范围", Type:=8)
    
25.     On Error GoTo 0
    
26.     If userRange Is Nothing Then Exit Sub ' 用户没有选择范围
    
27.    
    
28.     ' 关闭屏幕更新以提高性能
    
29.     Application.ScreenUpdating = False
    
30.    
    
31.     ' 遍历用户选择的范围内的每个单元格
    
32.     For Each cell In userRange
    
33.         cellText = cell.Value
    
34.         ' 遍历文本的所有可能子字符串
    
35.         For i = minSubstringLength To Len(cellText)
    
36.             ' 遍历文本，从第一个字符开始
    
37.             For j = 1 To Len(cellText) - i + 1
    
38.                 currentSubstring = Mid(cellText, j, i)
    
39.                 ' 检查后续文本中是否有匹配的子字符串
    
40.                 foundMatch = False
    
41.                 For k = j + 1 To Len(cellText) - i + 1
    
42.                     If Mid(cellText, k, i) = currentSubstring Then
    
43.                         ' 找到匹配项，标红匹配文本
    
44.                         cell.Characters(j, i).Font.Color = RGB(255, 0, 0)
    
45.                         foundMatch = True
    
46.                         Exit For
    
47.                     End If
    
48.                 Next k
    
49.                 ' 如果找到匹配，可以跳出内层循环避免重复标红
    
50.                 If foundMatch Then Exit For
    
51.             Next j
    
52.         Next i
    
53.     Next cell
    
54.    
    
55.     ' 重新开启屏幕更新
    
56.     Application.ScreenUpdating = True
    
57.    
    
58.     MsgBox "标红完成！", vbInformation
    
59. End Sub

复制代码