VBA关于多工作簿查询包含指定的字符的应用（很难的）

ericjon

我本来是打算一次就打开的，因为我的系统是win7，打开相同的程序都组合在一起了，没注意到同时打开很多workbook任务栏的问题。我已经按照修改了下程序了。另谢谢楼上的那个getobject函数，这个得确好用。

zjdh

21楼的速度快，20楼的把“A1"单元的搜索排除在外了，
对位的思路学习了！

kevinchengcw

Sub test()
Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, Str$, Rng As Range, Str2$
Set Dic = CreateObject("scripting.dictionary")
Str = InputBox("查找内容:", "输入")
If Str = "" Then Exit Sub
Application.ScreenUpdating = False
FN = Dir(ThisWorkbook.Path & "\*.xls*")
Do While FN <> ""
    If FN <> ThisWorkbook.Name Then
        Set Wb = GetObject(ThisWorkbook.Path & "\" & FN)
        With Wb
            For Each Ws In .Worksheets
                With Ws
                    If WorksheetFunction.CountIf(.UsedRange, "*" & Str & "*") <> 0 Then
                        Set Rng = .UsedRange.Find(Str)
                        Do
                            Str2 = Left(Wb.Name, InStrRev(Wb.Name, ".") - 1) & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value & vbTab & Rng.Offset(0, 2).Value
                            If Not Dic.exists(Str2) Then Dic.Add Str2, ""
                            Set Rng = .UsedRange.Find(Str, Rng)
                        Loop While .UsedRange.Find(Str).Address <> Rng.Address
                    End If
                End With
            Next Ws
        End With
        Wb.Close False
    End If
    FN = Dir
Loop
Set Wb = Nothing
With Worksheets("查询")
    .Rows("3:" & .Rows.Count).Clear
    If Dic.Count > 0 Then
        Arr = Dic.keys
        For N = LBound(Arr) To UBound(Arr)
            .Cells(N + 3, 1) = N + 1
            .Cells(N + 3, 2).Resize(1, 5) = Split(Arr(N), vbTab)
        Next N
        .[a3].Resize(N, 6).Borders.LineStyle = 1
    End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
MsgBox "查找完成"
End Sub

继续优化

a216516

无意走进了VAB，路过，本人很菜，看不懂代码，不过很喜欢EXCELHOME这个家的这个感觉！！！

wangzhongtu

1.你的程序测试我5月份的100份工作簿，非常成功，用时49.32秒
2.当测试到其它月份的几十份工作簿时，却发现问题：
If Len(tempCell.Value) > 0 Then提示这句代码出错

wangzhongtu

我找了好久的病因，排除了n份工作簿没问题，最终确定了其中一份工作簿不能成功，刚想上传发现23楼还有你修改过的程序代码，现在用过感觉特别好用，暂时没发现其它什么问题

刚才用你的程序测试我5月份的100份工作簿，非常成功，用时43.97秒
对其它的月份的工作簿测试过也很成功！！！

对了，能否再增加一个简单的提示：如果查找不到要搜索的关键字，那么程序结束前提示“你要搜索的信息不存在！”的对话框，这样看起来会更好点！！！

[ 本帖最后由 wangzhongtu 于 2010-10-30 20:06 编辑 ]

kevinchengcw

Sub test()
Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, Str$, Rng As Range, Str2$
Set Dic = CreateObject("scripting.dictionary")
Str = InputBox("查找内容:", "输入")
If Str = "" Then Exit Sub
Application.ScreenUpdating = False
FN = Dir(ThisWorkbook.Path & "\*.xls*")
Do While FN <> ""
    If FN <> ThisWorkbook.Name Then
        Set Wb = GetObject(ThisWorkbook.Path & "\" & FN)
        With Wb
            For Each Ws In .Worksheets
                With Ws
                    If WorksheetFunction.CountIf(.UsedRange, "*" & Str & "*") <> 0 Then
                        Set Rng = .UsedRange.Find(Str)
                        Do
                            Str2 = Left(Wb.Name, InStrRev(Wb.Name, ".") - 1) & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value & vbTab & Rng.Offset(0, 2).Value
                            If Not Dic.exists(Str2) Then Dic.Add Str2, ""
                            Set Rng = .UsedRange.Find(Str, Rng)
                        Loop While .UsedRange.Find(Str).Address <> Rng.Address
                    End If
                End With
            Next Ws
        End With
        Wb.Close False
    End If
    FN = Dir
Loop
Set Wb = Nothing
With Worksheets("查询")
    .Rows("3:" & .Rows.Count).Clear
    If Dic.Count > 0 Then
        Arr = Dic.keys
        For N = LBound(Arr) To UBound(Arr)
            .Cells(N + 3, 1) = N + 1
            .Cells(N + 3, 2).Resize(1, 5) = Split(Arr(N), vbTab)
        Next N
        .[a3].Resize(N, 6).Borders.LineStyle = 1
        MsgBox "查找完成"
    else
        msgbox "不存在你要搜索的内容"
    End If
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

[ 本帖最后由 kevinchengcw 于 2010-10-30 20:08 编辑 ]

wangzhongtu

太好了 非常感谢！！！

狼夸羊肥

已经下载使用，的确非常好，21楼的运行发生错误，是那句宽度属性样有问题。

wangzhongtu

请高手帮助解释下程序代码中的以下几个问题：

1.这句的函数什么意思？怎么使用？
InStrRev(Wb.Name, ".") - 1
2.两句什么意思？有什么区别：
&nbsp;Set Rng = .UsedRange.Find(Str)
Set Rng = .UsedRange.Find(Str, Rng)
3.为什么后面带上“, ""”符号，起到什么作用
If Not Dic.exists(Str2) Then Dic.Add Str2, ""
"4.句中Split(Arr(N), vbTab)的函数不是向右截掉vbTab的开始的所有内容吗，
这个vbTab符号在Str中出现了很多，按理说应该只保留工作簿名呀，请解释下"
.Cells(N + 3, 2).Resize(1, 5) = Split(Arr(N), vbTab)