求助vba查询搜索问题

wzs07

目标：
我有textbox1、textbox2及按键1；textbox1为待查询的关键词；textbox2为待查询的范围，
1.如textbox2为空，则查询范围为工作表的除第一行以外的全部有数据区域；
2.支持连序列采用“-”输入，如2-6表示工作表的2-6列的数据（不含第一行）；3.支持多列“;”输入，如2;5;6表示查询区域为第2列和第5列和第六列的数据（不含第一行）；点击按键1，首先删除第一个工作表的第一行以外的数据；然后从第二个工作表开始循环每个工作表，在textbox2的区域中搜索包含textbox1关键词（可以局部匹配）的行，将该行包含数据的区域依次赋值到第一个工作表除第一行以外的区域；同时对第一个工作表中在textbox2的区域中的text1的关键词标记红色请尽量采用字典写入的方法加快速度；




chatgpt的下述代码问题：1.支持-输入法，不支持；的识别；
2.不支持单独数字的输入，如输入8，报错
3.高亮文本对整个区域整个单元格高亮了，要求时textbox2对应的区域仅搜索文本高亮
请大神优化代码，代码是不是可以有加速的空间
业绩整理台账 -.rar (17.16 KB, 下载次数: 4)

2024-5-7 14:30 上传

点击文件名下载附件

1. Sub SearchAndHighlight()
   
2.     Dim ws As Worksheet
   
3.     Dim firstSheet As Worksheet
   
4.     Dim keyWord As String
   
5.     Dim searchRange As String
   
6.     Dim rng As Range
   
7.     Dim cell As Range
   
8.     Dim dict As Object
   
9.     Dim i As Long, j As Long
   
10.     Dim colStart As Long, colEnd As Long
    
11.     Dim colsArray() As String
    
12.     Dim targetRow As Long
    
13. 
    
14.     Set firstSheet = ThisWorkbook.Worksheets(1)
    
15.     keyWord = TextBox1.Value
    
16.     searchRange = TextBox2.Value
    
17.     targetRow = 2
    
18. 
    
19.     ' 清除第一个工作表的数据（除了第一行）
    
20.     firstSheet.Rows("2:" & firstSheet.Rows.Count).Delete
    
21. 
    
22.     ' 创建字典以加快数据写入速度
    
23.     Set dict = CreateObject("Scripting.Dictionary")
    
24. 
    
25.     ' 循环处理每个工作表
    
26.     For Each ws In ThisWorkbook.Worksheets
    
27.         If ws.Index <> 1 Then
    
28.             ' 确定搜索范围
    
29.             If searchRange = "" Then
    
30.                 Set rng = ws.UsedRange.Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1)
    
31.             ElseIf InStr(searchRange, "-") > 0 Then
    
32.                 colsArray = Split(searchRange, "-")
    
33.                 colStart = colsArray(0)
    
34.                 colEnd = colsArray(1)
    
35.                 Set rng = ws.Range(ws.Cells(2, colStart), ws.Cells(ws.UsedRange.Rows.Count, colEnd))
    
36.             ElseIf InStr(searchRange, ";") > 0 Then
    
37.                 colsArray = Split(searchRange, ";")
    
38.                 For i = LBound(colsArray) To UBound(colsArray)
    
39.                     If i = LBound(colsArray) Then
    
40.                         Set rng = ws.Columns(colsArray(i)).Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1)
    
41.                     Else
    
42.                         Set rng = Union(rng, ws.Columns(colsArray(i)).Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1))
    
43.                     End If
    
44.                 Next i
    
45.             End If
    
46. 
    
47.             ' 搜索关键词并复制数据
    
48.             For Each cell In rng
    
49.                 If InStr(cell.Value, keyWord) > 0 Then
    
50.                     ' 将整行数据复制到第一个工作表
    
51.                     ws.Rows(cell.Row).Copy Destination:=firstSheet.Rows(targetRow)
    
52.                     targetRow = targetRow + 1
    
53. 
    
54.                     ' 标记包含关键词的单元格为红色
    
55.                     firstSheet.Cells(targetRow - 1, cell.Column).Font.Color = RGB(255, 0, 0)
    
56.                 End If
    
57.             Next cell
    
58.         End If
    
59.     Next ws
    
60. End Sub

复制代码