[已解决]求修复代码，原代码运行慢！谢谢！

fggf

自己网上参考写了段代码，运行很慢，求修改！比如只查找“南”字，运行起来要约35秒时间。求各位老师帮忙，谢谢！ 模糊查找.rar (81.56 KB, 下载次数: 12)

2017-9-26 16:49 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-9-26 21:53

Private Sub CommandButton1_Click()
If TextBox1.Text = "" Then
    MsgBox "请输入要查找的简称!": Exit Sub
End If
Dim arr, rgs As Range
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rows("31:10000").Hidden = False
arr = Range("b1:b10000")
For i = 31 To 10000
    If (arr(i, 1) Like "*" & TextBox1.Text & "*") = False Then
        If rgs Is Nothing Then
        Set rgs = Range("a" & i)
        Else
        Set rgs = Union(rgs, Range("a" & i))
        End If

    End If
'    If (Cells(i, 2) Like "*" & TextBox1.Text & "*") = False Then
'        Range("a" & i).EntireRow.Hidden = True
'    End If
Next
rgs.EntireRow.Hidden = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
用数组会快点

跳转到最佳答案楼层

大灰狼1976

1. Private Sub CommandButton1_Click()
   
2. If TextBox1.Text = "" Then
   
3. MsgBox "请输入要查找的简称!": Exit Sub
   
4. End If
   
5. Application.ScreenUpdating = False
   
6. Application.Calculation = xlCalculationManual
   
7. Rows("31:10000").Hidden = False
   
8. Range("a31:i" & [b65536].End(3).Row).AutoFilter Field:=2, Criteria1:="*" & TextBox1 & "*", Operator:=xlFilterValues
   
9. Application.Calculation = xlCalculationAutomatic
   
10. Application.ScreenUpdating = True
    
11. End Sub
    
12. 
    
13. Private Sub CommandButton2_Click()
    
14.     VBA.Unload UserForm1
    
15. End Sub
    
16. 
    
17. Private Sub CommandButton3_Click()
    
18. Application.ScreenUpdating = False
    
19. Application.Calculation = xlCalculationManual
    
20. Range("a31:i" & [b65536].End(3).Row).AutoFilter
    
21.          
    
22. Application.Calculation = xlCalculationAutomatic
    
23. Application.ScreenUpdating = True
    
24. End Sub

复制代码

fggf

大灰狼1976 发表于 2017-9-26 17:04

怎么我的运行起来出错呢，运行时错误‘1004’  类range的autofilter方法无效。不知哪里错了，帮我看看啊

苏子龙

Private Sub CommandButton1_Click()
If TextBox1.Text = "" Then
    MsgBox "请输入要查找的简称!": Exit Sub
End If
Dim arr, rgs As Range
t = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rows("31:10000").Hidden = False
arr = Range("b1:b10000")
For i = 31 To 10000
    If (arr(i, 1) Like "*" & TextBox1.Text & "*") = False Then
        If rgs Is Nothing Then
        Set rgs = Range("a" & i)
        Else
        Set rgs = Union(rgs, Range("a" & i))
        End If

    End If
'    If (Cells(i, 2) Like "*" & TextBox1.Text & "*") = False Then
'        Range("a" & i).EntireRow.Hidden = True
'    End If
Next
rgs.EntireRow.Hidden = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
用数组会快点

大灰狼1976

有现成的自动筛选功能不用真是可惜，处理这种问题的速度无出其右。
代码出错可能是你套用的问题，我把附件给你测试一下。
注意：由于我的EXCEL版本问题，VBA里面的汉字内容都用“！”代替了，你自己重新改下。

fggf

大灰狼1976 发表于 2017-9-27 09:00
有现成的自动筛选功能不用真是可惜，处理这种问题的速度无出其右。
代码出错可能是你套用的问题，我把附件 ...

谢谢您哈！[em17]