实在受不了这个速度了！查找并选中指定字符单元格！

wfchenyiting

各位老师，附件是5600行左右的数据，需要在表中查找并选定所有 包含 “昆山" 字符的单元格，我自己写了段代码，居然用时要13-14秒。真心受不了这个速度！请论坛大神们指导，有什么可以快速的方法得到同样的结果啊？？？谢谢！

1. Sub 查找()
   
2.     Dim FindSt$, Rg1 As Range, Rg2 As Range, Arr
   
3.     Dim RgA$, RgCol As Range, x%, t
   
4.     FindSt = "昆山"
   
5.     Application.ScreenUpdating = False
   
6.     t = Timer
   
7.     Arr = [a1].CurrentRegion
   
8.     Set Rg1 = Range("a1").Resize(UBound(Arr), UBound(Arr, 2))
   
9.     Set Rg2 = Rg1.Find(FindSt, , , xlPart)
   
10.     If Rg2 Is Nothing Then Exit Sub
    
11.     RgA = Rg2.Address
    
12.     Set RgCol = Rg2
    
13.     Do
    
14.         x = x + 1
    
15.         Set Rg2 = Rg1.Find(FindSt, Rg2, , xlPart)
    
16.         Set RgCol = Union(RgCol, Rg2)
    
17.     Loop While Rg2.Address <> RgA
    
18.     RgCol.Select
    
19.     MsgBox "查询到包含字符：" & FindSt & " 共计：" & x & _
    
20.         "条记录！" & vbCrLf & "用时：" & Timer - t & " 秒！" & _
    
21.         vbCrLf & vbCrLf & "---Find 查询！"
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

micch

直接用系统的查找 ctrl+H 好像也不快
选中单元格，就只能在单元格区域一个一个依次操作，快不起来

qingc0221

为什么直接在表中查啊?放入数组中不好吗

jiangxiaoyun

筛选就很快，尝试一下

wfchenyiting

qingc0221 发表于 2019-1-19 19:26
为什么直接在表中查啊?放入数组中不好吗

主要是为了查找到并选中符合的单元格啊。否则还有什么好的方法实现啊？谢谢

wfchenyiting

jiangxiaoyun 发表于 2019-1-19 19:27
筛选就很快，尝试一下

如何筛选啊？老师，代码可以实现？帮忙看看呢

719404338

1. Sub t()
   
2. Dim i, j, x, t
   
3. t = Timer
   
4. For i = 2 To [a65536].End(3).Row
   
5. For j = 1 To 20
   
6. If InStr(Cells(i, j), "昆山") Then
   
7. x = x + 1
   
8. End If
   
9. Next j, i
   
10. MsgBox "查询到包含字符：" & FindSt & " 共计：" & x & "条记录！" & vbCrLf & "用时：" & Timer - t & " 秒！" & vbCrLf & vbCrLf & "---Find 查询！"
    
11. End Sub
    

复制代码

wfchenyiting

719404338 发表于 2019-1-19 19:41

谢谢老师的代码，instr 我也试过，如果仅是判断是否包含，是好像比find的速度快些，但是您的代码没有对符合条件的单元格进行选中的需求。请老师增加选中的代码呢。谢谢

chis3

Sub test()
    Dim arr
    Dim brr
    Dim i As Integer
    Dim j As Byte
    Dim t As Long
    Dim rng As Range
    t = Timer
    arr = [a1].CurrentRegion
    For i = 2 To UBound(arr)
        brr = Application.Transpose(Range("a" & i & ":" & "s" & i))
        If InStr(1, Join(Application.Transpose(brr), ","), "昆山", vbTextCompare) > 0 Then
            brr = Range("a" & i & ":" & "s" & i)
            For j = 1 To UBound(brr, 2)
                If InStr(1, brr(1, j), "昆山", vbTextCompare) > 0 Then
                    If rng Is Nothing Then
                        Set rng = Cells(i, j)
                    Else
                        Set rng = Union(rng, Cells(i, j))
                    End If
                End If
            Next j
        End If
    Next i
    rng.Select
    MsgBox Format(Timer - t, "0.00")
End Sub

也快不多,主要還是太多循環,但我看到你也不是全部格仔也需要找,只有數行要找吧
那就只集中在數行,應該快不少

wfchenyiting

chis3 发表于 2019-1-19 20:11
Sub test()
    Dim arr
    Dim brr

复制了您的代码，运行了下，确实速度并没有显著的变化，不过还是非常感谢您的代码和指导。谢谢



期待其它老师能帮忙优化下，谢谢！