有偿求助！！关于vba的find函数

tongtong61

谢谢论坛热心的大神，本人新手，自己写了一段代码，但有一点小问题，一直没解决，第一位帮助我解决的网友留下支付宝账号，我会发一个小红包，再次感谢！

实例如下：
附件中，从一个文件夹下所有工作表中，查找包含“要查找目录.xls” A列的内容，并把查找到的结果整行复制到“要查找目录.xls” 的sheet2中。

我的问题：
1、查找的结果中有很多的空行，不知道原因；
2、数据很多很大的时候是否需要把要查找的内容写入数组提高效率；
3、麻烦老师帮我指出问题所在并调试一下，拜谢！！


代码和附件如下：

1. Sub test()
   
2. Dim mypath$, myname$
   
3. mypath = ThisWorkbook.Path & ""
   
4. myname = Dir(mypath & "*.*")
   
5.     Do While myname <> "" And myname <> "要查找的目录.xls"
   
6.         With Workbooks.Open(mypath & myname)
   
7.             .Sheets(1).Select
   
8.            Call 查找
   
9.             .Close True
   
10.         End With
    
11.         myname = Dir
    
12.     Loop
    
13. End Sub
    
14. 
    
15. 
    
16. Sub 查找()
    
17. 
    
18. Dim dic
    
19. Dim m, irow As Integer
    
20. Set dic = CreateObject("scripting.dictionary")
    
21. brr = ActiveWorkbook.Sheets(1).Range("a1").CurrentRegion.Value
    
22. ReDim arr(1 To UBound(brr), 1 To UBound(brr, 2))
    
23. irow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row
    
24. For m = 1 To irow
    
25. With ActiveWorkbook.Sheets(1).Range("1:65536")
    
26.     Set c = .Find(ThisWorkbook.Sheets(1).Range("a" & m).Value, LookIn:=xlValues, lookat:=xlPart)
    
27.     If Not c Is Nothing Then
    
28.     firstaddress = c.Address
    
29.     Do
    
30.         If Not dic.exists(c.Row) Then
    
31.         dic(c.Row) = dic.Count + 1
    
32.         n = dic.Count
    
33.         For j = 1 To UBound(brr, 2)
    
34.             arr(n, j) = brr(c.Row, j)
    
35.         Next
    
36.         End If
    
37.         Set c = .FindNext(c)
    
38.      Loop While Not c Is Nothing And c.Address <> firstaddress
    
39.          End If
    
40. End With
    
41. 
    
42. If c Is Nothing Then
    
43. k = 2
    
44. Else:
    
45. ThisWorkbook.Sheets(2).Range("a" & Range("a65536").End(xlUp).Row).Resize(dic.Count, UBound(brr, 2)).Value = arr
    
46. End If
    
47. Next
    
48. 
    
49. End Sub

复制代码

wang-way

联系我 让我试试

yylucke

你直接说你的目的吧，你的代码有些乱。

wang-way

用到VBA和数组 就不用FIND方法了

tongtong61

yylucke 发表于 2020-5-29 10:50
你直接说你的目的吧，你的代码有些乱。

就是对查找很多个工作薄中，含有特定文字的单元格，并把整行复制出来

wang-way

1. 代码都在后面的附件里

复制代码

wang-way

1. 代码都在后面的附件里

复制代码

wang-way

1. 代码都在后面的附件里

复制代码

wang-way

这是 测试好的附件  审核速度有点

yylucke

Dim DicFindStr '定义为模块变量，用于装入要查找的关键字
Sub test()
Application.ScreenUpdating = False
    Dim irow As Long
    Set DicFindStr = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("a1").CurrentRegion
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then DicFindStr(arr(i, 1)) = ""
    Next i
   
    '清空Sheet2
    Sheet2.Cells.ClearContents
    irow = 0
    Dim mypath$, myname$
    mypath = ThisWorkbook.Path & "\"
    myname = Dir(mypath & "*.*")
    Do While myname <> "" And myname <> "要查找的目录.xls"
        Set findWB = Workbooks.Open(mypath & myname)
         With findWB
            brr = .Sheets(1).Range("a1").CurrentRegion
            For i = 1 To UBound(brr)
                If DicFindStr.exists(brr(i, 4)) Or DicFindStr.exists(brr(i, 6)) Then
                    irow = irow + 1
                    ThisWorkbook.Sheets(2).Cells(irow, 1).Resize(1, 46) = Application.Index(brr, i)
                End If
            Next i
            .Close True
        End With
        myname = Dir
    Loop
    Application.ScreenUpdating = True
End Sub