使用Excel

Question

我目前正在尝试编辑我当前使用的同事的宏，该脚本当前打开一个消息框，允许您输入一个字符串，然后搜索该字符串并将结果粘贴到工作簿中。我想更改此内容，以便搜索电子表格中已有的列表，然后将结果粘贴到下一个工作表中。我不确定这是否真的可能，这是我的主要斗争。下面是当前代码，我假设所需要的只是将变量范围放在那些星星中＆＃34; msg =＆＃34;输入文件名和扩展名＆＃34;

Sub Filesearch()
 Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        End If
    End With
    msg = "Enter File name and Extension" & vbLf & "following wild" & _
    " cards can be used" & vbLf & "* # ?"
    myExtension = Application.InputBox(msg)
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "No file found"
    End If
End Sub


Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
            * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
            * (UCase(myFile.Name) Like UCase(myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function

Answer 1

建议使用Defined Name Ranges来保存用户维护列表（如下图所示）

让我们为用户输入名为“_Tables”的需求添加一个工作表。 然后创建Defined Name Ranges，供用户输入要求，称为"_Path"，"_Files"和"_SubFldrs"

然后替换当前代码中的所有用户输入

REPLACE THIS
'''    With Application.FileDialog(msoFileDialogFolderPicker)
'''        If .Show Then
'''            myDir = .SelectedItems(1)
'''        End If
'''    End With
'''    msg = "Enter File name and Extension" & vbLf & "following wild" & _
'''    " cards can be used" & vbLf & "* # ?"
'''    myExtension = Application.InputBox(msg)
'''    If (myExtension = "False") + (myExtension = "") Then Exit Sub
'''    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
'''    SearchSubFolders = Rtn = 6

用这个来阅读工作表中的要求＆＃34; _Tables＆＃34;

    Set WshLst = ThisWorkbook.Sheets("_Tables")
    sPath = WshLst.Range("_Path").Value2
    aFleKey = WshLst.Range("_Files").Value2
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
    aFleKey = WorksheetFunction.Transpose(aFleKey)

然后处理列表 请参阅下面的完整代码。在模块顶部使用语句Option Base 1

是必要的

Option Explicit
Option Base 1

Sub Fle_FileSearch_List()
Dim WshLst As Worksheet
Dim sPath As String
Dim aFleKey As Variant, vFleKey As Variant
Dim bSbFldr As Boolean
Dim vFleLst() As Variant
Dim lN As Long

    Set WshLst = ThisWorkbook.Sheets("_Tables")
    sPath = WshLst.Range("_Path").Value2
    aFleKey = WshLst.Range("_Files").Value2
    bSbFldr = UCase(WshLst.Range("_SubFldrs").Value2) = UCase("YES")
    aFleKey = WorksheetFunction.Transpose(aFleKey)

    Rem To clear output location
    ThisWorkbook.Sheets(1).Columns(1).Resize(, 2).Clear

    Rem Process input list
    For Each vFleKey In aFleKey
        If (vFleKey <> "False") * (vFleKey <> "") Then
        Call Fle_FileSearch_Fldrs(sPath, CStr(vFleKey), lN, vFleLst, bSbFldr)
    End If: Next

    Rem Validate Results & List Files found
    If lN > 1 Then
        ThisWorkbook.Sheets(1).Cells(1).Resize(UBound(vFleLst, 2), 2) _
            .Value = Application.Transpose(vFleLst)
    Else
        MsgBox "No file found"
    End If

End Sub

还对函数（现在是一个程序）进行了一些调整，以允许列表进程。

Sub Fle_FileSearch_Fldrs(sPath As String, _
    sFleKey As String, lN As Long, vFleLst() As Variant, _
    Optional bSbFldr As Boolean = False)

Dim oFso As Object, oFolder As Object, oFile As Object

    Set oFso = CreateObject("Scripting.FileSystemObject")

    If lN = 0 Then
        lN = 1 + lN
        ReDim Preserve vFleLst(1 To 2, 1 To lN)
        vFleLst(1, lN) = "Files Found - Path"
        vFleLst(2, lN) = "Files Found - Name"
    End If

    For Each oFile In oFso.GetFolder(sPath).Files
        Select Case oFile.Attributes
        Case 2, 4, 6, 34    
        Case Else
            If (Not oFile.Name Like "~$*") * _
                (oFile.Path & "\" & oFile.Name <> ThisWorkbook.FullName) * _
                (UCase(oFile.Name) Like UCase(sFleKey)) Then

                lN = lN + 1
                ReDim Preserve vFleLst(1 To 2, 1 To lN)
                vFleLst(1, lN) = sPath
                vFleLst(2, lN) = oFile.Name

    End If: End Select: Next

    If bSbFldr Then
        For Each oFolder In oFso.GetFolder(sPath).subfolders
            Call Fle_FileSearch_Fldrs(oFolder.Path, sFleKey, lN, vFleLst, bSbFldr)
    Next: End If

End Sub