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

wangzhongtu

多工作簿查找包含指定的字符
大致思路：点击按钮，清空A3:E65536区域单元格内容及边框；然后弹出对话框，输入要查找的关键字符（比如“防盗锁”）后；点击确定，则开始查找当前路径下所有工作簿（不含本工作簿）中含有关键字符的单元格，并将找到的字符所在的工作簿名、工作表名、单元格地址、单元格内容显示在表格中，并自动添加序号及边框；同时希望能在状态栏中显示出完成进度,完成后弹出完成对话框，然后点击确定结束程序。

这是工作中碰到的一个难题，实际工作中工作簿每个月都有上百份，因本人技术菜，想了半个多月了还是没做出来，希望高手们能来帮忙实现效果！万分感激！附件已经上传！

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

yrysf

会者不难,难者不会啊!

yrysf

能否把多个工作簿的文件导入到一个工作簿内，然后这样查找岂不是容易多了？

wangzhongtu

会者不难,难者不会   这句话很现实

至于多工作簿文件导入到一个工作簿内，显然是行不通的，查找的关键字符的所在工作簿名必须要能知道的，否则就达不到我的目的，   
原因：正常的话，我每个月要做100来份成本立项表，而材料价格是很难确定的，很难找到，但是有些价格以前做立项表时已经确认过的，如果用普通方法要在上千份立项表中找出不常用材料的价格似乎不现实，如果我的求助能得到帮助，就可以解决此问题了，希望能有朋友帮助解决！

[ 本帖最后由 wangzhongtu 于 2010-10-28 19:58 编辑 ]

蓝桥玄霜

建议搜索多工作簿提取数据，论坛有不少类似的实例。查找可用Find+FindNext，估计只有完成进度表需要重新设计。

kevinchengcw

Sub test()
Dim Dic, Wb As Workbook, Ws As Worksheet, Arr, N&, FN$, Str$, Rng As Range
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
                    Set Rng = .[a1]
                    If Not .Cells.Find(Str, Rng) Is Nothing Then
                        Do While .Cells.Find(Str, Rng).Row > Rng.Row Or .Cells.Find(Str, Rng).Column > Rng.Column
                            Set Rng = .Cells.Find(Str, Rng)
                            Dic.Add Left(Wb.Name, InStrRev(Wb.Name, ".") - 1) & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value, ""
                        Loop
                    End If
                End With
            Next Ws
        End With
        Wb.Close False
    End If
    FN = Dir
Loop
Set Wb = Nothing
Arr = Dic.keys
With Worksheets("查询")
    .Rows("3:" & .Rows.Count).Clear
    For N = LBound(Arr) To UBound(Arr)
        .Cells(N + 3, 1) = N + 1
        .Cells(N + 3, 2).Resize(1, 4) = Split(Arr(N), vbTab)
    Next N
    .[a3].Resize(N, 6).Borders.LineStyle = 1
End With
Set Dic = Nothing
Application.ScreenUpdating = True
MsgBox "查找完成"
End Sub

wangzhongtu

太神奇了！非常感谢！！！非常好用！完全达到了效果！  刚才用了你的程序已经找出了之前找不到的材料价格了。  这个程序似乎可以给你加精哦  可是我没权限加  呵呵  
至于完成进度问题 我自己添加就可以了
强！！！

kevinchengcw

上百份的话应该还不用显示进度吧，等你测试一下速度再说。

wangzhongtu

刚才我把10个月的工作簿都测试了下 ，   我用的搜索关键字是“防盗锁” ， 发现点问题：
一.成功的有2个月，所花时间大概在20-30秒之间（60份工作簿）
二.不成功的有8个月，其中分两种情况：
   
   1.执行后大概30多秒钟时，出错，我将其中的工作簿添加了需要搜索的关键字，后再执行，结果还是出同样的问题，
   2.工作簿中没有搜索到关键字符  会出错 ，如果打开一张工作簿  加入需要搜索的关键字符后 ，则执行成功，
已上传了错误截图，请kevinchengcw 看看  ！同时请你帮忙对代码做些解释! 也好方便大家学习

[ 本帖最后由 wangzhongtu 于 2010-10-28 22:51 编辑 ]

weide_yang

kevinchengcw老师的方法真是很好，本人也正有此需要。
在此也向kevinchengcw老师说声谢谢！！！