要求跨工作簿模糊查找

冷酷的云

Sub 数组法()
    Dim arr, brr(), i&, m&, s$, Workbook
    s = [c1]
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\A")
    arr = Range("a2:c" & [a65536].End(xlUp).Row)
    Windows("A.xls").Close True
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), s) Then
            m = m + 1
            brr(m, 1) = arr(i, 2)
        End If
    Next
    Range("d2:F65536").ClearContents
    If m > 0 Then [d2].Resize(m, 3) = arr
End Sub
请大师帮忙看下，哪错了，要求跨工作簿模糊查找 模糊查找.rar (15.73 KB, 下载次数: 7)

2018-12-18 20:04 上传

点击文件名下载附件

lsc900707

对比一下修改的地方：

1. Sub 数组法()
   
2.     Dim arr, brr(1 To 9999, 1 To 3), i&, m&, s$, Workbook
   
3.     s = [c1]
   
4.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\A.xls")
   
5.     arr = wb.Sheets(1).[a1].CurrentRegion
   
6.     wb.Close
   
7.     For i = 1 To UBound(arr)
   
8.         If InStr(arr(i, 1), s) Then
   
9.             m = m + 1
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 brr(m, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     Range("d2:F" & Rows.Count).ClearContents
    
16.     If m > 0 Then [d2].Resize(m, 3) = brr
    
17. End Sub
    

复制代码

lsc900707

参考测试附件：

冷酷的云

lsc900707 发表于 2018-12-18 20:21
参考测试附件：

大师你好：为什么我在A列与B列插入一列空白列，使B列变C列为个么提取过来只有一列数据，要怎么修改。

lsc900707

冷酷的云 发表于 2018-12-18 22:05
大师你好：为什么我在A列与B列插入一列空白列，使B列变C列为个么提取过来只有一列数据，要怎么修改。

插入空白列后currentregion就出现错误了。具体你先规划好表格，我再看你的附件修改吧。

冷酷的云

模糊查找.rar (12.23 KB, 下载次数: 4)

2018-12-18 22:51 上传

点击文件名下载附件

重新上传，辛苦大师了

lsc900707

冷酷的云 发表于 2018-12-18 22:51
重新上传，辛苦大师了

1. Sub 数组法()
   
2.     Dim brr(1 To 9999, 1 To 11)
   
3.     Application.ScreenUpdating = False
   
4.     Set wb = Workbooks.Open(ThisWorkbook.Path & "\A.xls")
   
5.     arr = wb.Sheets(1).[a1].CurrentRegion
   
6.     wb.Close
   
7.     For i = 1 To UBound(arr)
   
8.         If InStr(arr(i, 1), [c1]) Then
   
9.             m = m + 1
   
10.             For j = 1 To UBound(arr, 2)
    
11.                 brr(m, j) = arr(i, j)
    
12.             Next
    
13.         End If
    
14.     Next
    
15.     If m > 0 Then
    
16.         [c1].CurrentRegion.Offset(1, 1).ClearContents
    
17.         [d2].Resize(m, 11) = brr
    
18.     End If
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

lsc900707

冷酷的云 发表于 2018-12-18 22:51
重新上传，辛苦大师了

附件供测试参考：

会志

请问老师，如何循环下一个关键词你，如BX

shiruiqiang

会志 发表于 2023-6-13 17:25
请问老师，如何循环下一个关键词你，如BX

建议字典处理。