EXCEL2007和EXCEL2013都不支持Set fs = Application.FileSearch 提示对象不支持该动作

nmcfbgttyl

下面这段代码，运行到 Set fs = Application.FileSearch 提示对象不支持该动作，2007以上版本就不支持吗，怎样改呢？谢谢各位！
Public Sub 技巧11_005()
    Dim myPath As String, DefaultPath As String, mysql As String
    Dim i As Integer, j As Integer, n As Integer, p As Integer
    Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer
    Dim cnn As ADODB.Connection
    Dim rs As ADODB.Recordset
    '删除当前工作簿的"原始数据汇总"工作簿的所有数据
    Worksheets("原始数据汇总").Cells.Clear
    '开始从指定的文件夹中寻找要汇总工作簿文件
    DefaultPath = ThisWorkbook.Path & "\初一年级\"
    myPath = InputBox("请输入要查询工作簿的文件夹完整目录及名字：" _
         & vbCrLf & vbCrLf & "如果为空，则默认为" & vbCrLf _
         & DefaultPath, "输入路径", DefaultPath)
    If myPath = "" Then myPath = DefaultPath
    Application.StatusBar = "正在查找汇总工作簿......"
    Set fs = Application.FileSearch
    With fs
        .LookIn = myPath
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute(SortBy:=msoSortByFileName, _
                SortOrder:=msoSortOrderAscending) > 0 Then
            p = .FoundFiles.Count
            MsgBox "在此文件夹中共有 " & p & " 个工作表的数据文件需要汇总！", _
            vbInformation, "搜索到汇总文件"
            ReDim myfile(p) As String
            For i = 1 To p
                myfile(i) = .FoundFiles(i)
            Next i
        Else
            MsgBox "没有搜索到要汇总的文件！", vbInformation, "没有汇总文件"
            Application.StatusBar = False
            Exit Sub
        End If
    End With
    '建立与每个工作簿的连接，查询全部数据记录,并复制到当前工作表"原始数据汇总"中
    For i = 1 To p
        '建立与每个作簿的连接
        Set cnn = New ADODB.Connection
        With cnn
            .Provider = "microsoft.jet.oledb.4.0"
            .ConnectionString = "Extended Properties=Excel 8.0;" _
                & "Data Source=" & myfile(i)
            .Open
        End With
        '查询每个工作簿的全部记录数据
        Set rs = New ADODB.Recordset
        mysql = "select * from [Sheet1$]"
        rs.Open mysql, cnn, adOpenKeyset, adLockOptimistic
        If i = 1 Then        '复制字段名称到"原始数据汇总"工作表
            For j = 0 To rs.Fields.Count - 1
                Worksheets("原始数据汇总").Cells(1, j + 1) = rs.Fields(j).Name
            Next j
        End If
        '获取当前工作簿的"原始数据汇总"工作表的最后一行数据
        n = Worksheets("原始数据汇总").Range("A65536").End(xlUp).Row
        If rs.RecordCount <> 0 Then
            '将查询到的学生记录复制到"汇总"工作表
            Worksheets("原始数据汇总").Range("A" & n + 1).CopyFromRecordset rs
        End If
    Next i
    Application.StatusBar = False
    MsgBox "工作簿汇总完毕！共汇总了 " & p & " 个工作簿。", vbInformation, "汇总完毕"
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

cbtaja

自 Microsoft Office 2003 以来的对象模型更改
全部显示
全部隐藏

下面是与 Microsoft Office 2003 相比的 Microsoft Office Excel 2007 对象模型更改的摘要。

Application
属性 状态
FileFind 隐藏
FileSearch 隐藏

excelxs2008

excel2007之后不再支持Application对象下的
FileSearch属性。可以使用Dir函数来解决此问题

flyingxbw

用fso 例子一：查询文件夹和子文件夹下的所有名为"Book1.xlsx"的文件
Sub Sample()
    Call FileSearch("C:\Sample", "Book1.xlsx")
End Sub

Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name = Target Then
            Debug.Print File.Path
        End If
    Next File
End Sub

flyingxbw

例子二：模糊查询
Sub Sample()
    Call FileSearch("C:\Sample", "2009-??.xls*")
End Sub

Sub FileSearch(Path As String, Target As String)
    Dim FSO As Object, Folder As Variant, File As Variant
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each Folder In FSO.GetFolder(Path).SubFolders
        Call FileSearch(Folder.Path, Target)
    Next Folder
    For Each File In FSO.GetFolder(Path).Files
        If File.Name Like Target Then
            Debug.Print File.Path
        End If
    Next File
End Sub

淘气的萝卜

顶一个

peter-chen

终于明白了了