子文件夹中多工作簿查询并返回路径

briancai20

在附件文件夹中的子文夹里的所有工作簿中查找77274并返回路径或是地址。请各位大侠拔刀相助吧。先谢过了。

zhaogang1960

ADO法请参考：
Sub Macro1()
    Dim Fso As Object, Folder As Object, cnn As Object, rs As Object, i&, SQL$, arrf$(), mf&, arr
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Folder = Fso.GetFolder(ThisWorkbook.Path)
    Application.ScreenUpdating = False
    Call GetFiles(Folder, arrf, mf)
    For l = 1 To mf
        Set cnn = CreateObject("ADODB.Connection")
        cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no;imex=1';Data Source=" & arrf(l)
'        MsgBox arrf(l)
        SQL = "SELECT * FROM [Sheet1$]"
        Set rs = cnn.Execute(SQL)
        If Not rs.EOF Then
            arr = rs.GetRows
            For i = 0 To UBound(arr)
                For j = 0 To UBound(arr, 2)
                    If arr(i, j) = "77274" Then
                        MsgBox "77274查到，所在文件是：" & vbCrLf & arrf(l)
                        GoTo 100
                    End If
                Next
            Next
        End If
    Next
100
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Folder = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

Sub GetFiles(ByVal Folder As Object, arr$(), m&)
    Dim SubFolder As Object
    Dim File As Object
    If Folder.Path <> ThisWorkbook.Path Then
        For Each File In Folder.Files
            If File.Name Like "*.xlsx" Then
                m = m + 1
                ReDim Preserve arr(1 To m)
                arr(m) = File
            End If
        Next
    End If
    For Each SubFolder In Folder.SubFolders
        Call GetFiles(SubFolder, arr, m)
    Next
End Sub

zhaogang1960

请测试附件
子文件夹多工作簿查找.rar (122.29 KB, 下载次数: 46)

2016-4-6 16:30 上传

点击文件名下载附件

briancai20

谢谢高手拔刀相助

LMY123

ADO,多夹多薄单表

jiminyanyan

LMY123 发表于 2018-7-26 11:40
ADO,多夹多薄单表

总结大师。。。