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

wangzhongtu

10楼说的没错  对了  kevinchengcw老师  是不是以前的kevin版主呀，我以前看过kevin的讲课视频呵呵，名字有点像
刚才我把测试了正好100份工作簿的速度，
第一次是48.34秒，
第二次是47.83秒，
不知道从专业技术角度来说是快还是慢！
本人还是很希望kevinchengcw老师  能够把6楼测试出的一些小毛病给避免掉去，至于“进度百分比”好像也很难弄哦  我刚才试着将进度百分比方面的代码添加到程序中，可还是没加成功，呵呵！！还得靠老师来弄了！希望kevinchengcw老师  对那些初学者可能看不懂的语句代码，能在附件的代码中能够作出点解释！！！这样我们也好学习了，说不定以后碰到类似的问题，也能自己解决了，还能帮助他人噢！！

yaozong

谢谢 kevinchengcw 大师分享，好方法，学习了。

ericjon

看看是不是这个意思吧，和8楼的实现方法有点不一样的。
对了，由于在非中文环境下做的，我把sheet名和查找的字符改为A，B了。

[ 本帖最后由 ericjon 于 2010-10-29 08:16 编辑 ]

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(.Cells, “*" & Str & "*") <> 0 Then
                        Set Rng = .[a1]
                        Do While .Cells.Find(Str, Rng).Row > Rng.Row Or .Cells.Find(Str, Rng).Column > Rng.Column
                            Set Rng = .Cells.Find(Str, Rng)
                            Str2 = Left(Wb.Name, InStrRev(Wb.Name, ".") - 1) & vbTab & Ws.Name & vbTab & Replace(Rng.Address, "$", "") & vbTab & Rng.Value
                            If Not Dic.exists(Str2) Then Dic.Add Str2, ""
                        Loop
                    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, 4) = 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

改成这样试一下，本地未测试

[ 本帖最后由 kevinchengcw 于 2010-10-29 13:00 编辑 ]

wangzhongtu

提示这句语法错误
If WorksheetFunction.CountIf(.Cells, “*" & Str & "*") <> 0 Then

wangzhongtu

刚才使用了下  总的来说很不错  
不过与我的题意有一点点不一样：搜索的关键字是包含的，所以如果单元格内容为：123我你他     那么输入“我”字后就会把含有“我”字的单元格的信息提取出来；而你的程序是把单元格的内容与关键字完全一样的，才能提出相关数据。
还有程序应该避免先一张一张打开所有的工作簿后，再一张张关闭所有的工作簿，我觉得这样任务栏太挤了，如果能打开一张工作簿-处理数据-关闭这张工作簿-再打开下一张工作簿，以此类推   用这种循环来打开、关闭工作簿会不会好点呢

    除了以上问题，没有发现其它不适合，代码保存了，工作上能用得到！
希望大家能把代码完善完善，这种程序有很多人都用得着的

wangzhongtu

方便的话希望能够在贴中的两个程序里添加点功能：
在备注栏显示出 被查找到的单元格向右偏移2个单元格的单元格的内容
不知道能否成全

kevinchengcw 大师能帮助解释以下代码吗？
1.      Set Wb = GetObject(ThisWorkbook.Path & "\" & FN)
  2.      For Each Ws In .Worksheets
  3.     Do While .Cells.Find(Str, Rng).Row > Rng.Row Or .Cells.Find(Str, Rng).Column > Rng.Column
  4.      Wb.Close False
还有以上第4句，为什么在这不关闭工作簿，而要等到向上循环打开下一张工作簿后，遇到以上的第二句代码时关闭第一张上一次打开的工作簿呢，还有也没有发现任务栏中有打开的工作簿呀，可是VBA编辑窗口中的工程里面明显有显示，真是惊奇！！！

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

kevinchengcw

1.      Set Wb = GetObject(ThisWorkbook.Path & "\" & FN)  '利用getobject打开工作簿（隐性打开，不会看到任务栏里有）
  2.      For Each Ws In .Worksheets   '循环当前打开的工作簿中的每个工作表
  3.     Do While .Cells.Find(Str, Rng).Row > Rng.Row Or .Cells.Find(Str, Rng).Column > Rng.Column  '当查找到的单元格的行或列大于上一次的单元格时继续循环（如果上一次找到的是最后一个，则再找会找到第一个，这时不会出现上面的任何一种情况，以此作为跳出循环的依据）
  4.      Wb.Close False   '关闭工作簿，并且不保存修改

kevinchengcw

原帖由 wangzhongtu 于 2010-10-29 18:14 发表
提示这句语法错误
If WorksheetFunction.CountIf(.Cells, “*" & Str & "*")  0 Then

If WorksheetFunction.CountIf(.Cells, "*" & Str & "*")  0 Then
出现了一个全角的双引号，应该是这里出错了

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(.Cells, “*" & Str & "*") <> 0 Then
                        Set Rng = .[a1]
                        Do While .Cells.Find(Str, Rng).Row > Rng.Row Or .Cells.Find(Str, Rng).Column > Rng.Column
                            Set Rng = .Cells.Find(Str, Rng)
                            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, ""
                        Loop
                    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

这样看一下会不会出现备注里你要的内容

注：后期的更改基本都是直接在这里改的，所以可能会有全角的符号，改成半角的基本就能正常了