|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 wzs07 于 2024-5-7 14:32 编辑
目标:
我有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)
- Sub SearchAndHighlight()
- Dim ws As Worksheet
- Dim firstSheet As Worksheet
- Dim keyWord As String
- Dim searchRange As String
- Dim rng As Range
- Dim cell As Range
- Dim dict As Object
- Dim i As Long, j As Long
- Dim colStart As Long, colEnd As Long
- Dim colsArray() As String
- Dim targetRow As Long
- Set firstSheet = ThisWorkbook.Worksheets(1)
- keyWord = TextBox1.Value
- searchRange = TextBox2.Value
- targetRow = 2
- ' 清除第一个工作表的数据(除了第一行)
- firstSheet.Rows("2:" & firstSheet.Rows.Count).Delete
- ' 创建字典以加快数据写入速度
- Set dict = CreateObject("Scripting.Dictionary")
- ' 循环处理每个工作表
- For Each ws In ThisWorkbook.Worksheets
- If ws.Index <> 1 Then
- ' 确定搜索范围
- If searchRange = "" Then
- Set rng = ws.UsedRange.Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1)
- ElseIf InStr(searchRange, "-") > 0 Then
- colsArray = Split(searchRange, "-")
- colStart = colsArray(0)
- colEnd = colsArray(1)
- Set rng = ws.Range(ws.Cells(2, colStart), ws.Cells(ws.UsedRange.Rows.Count, colEnd))
- ElseIf InStr(searchRange, ";") > 0 Then
- colsArray = Split(searchRange, ";")
- For i = LBound(colsArray) To UBound(colsArray)
- If i = LBound(colsArray) Then
- Set rng = ws.Columns(colsArray(i)).Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1)
- Else
- Set rng = Union(rng, ws.Columns(colsArray(i)).Offset(1, 0).Resize(ws.UsedRange.Rows.Count - 1))
- End If
- Next i
- End If
- ' 搜索关键词并复制数据
- For Each cell In rng
- If InStr(cell.Value, keyWord) > 0 Then
- ' 将整行数据复制到第一个工作表
- ws.Rows(cell.Row).Copy Destination:=firstSheet.Rows(targetRow)
- targetRow = targetRow + 1
- ' 标记包含关键词的单元格为红色
- firstSheet.Cells(targetRow - 1, cell.Column).Font.Color = RGB(255, 0, 0)
- End If
- Next cell
- End If
- Next ws
- End Sub
复制代码
|
|