查找文件并将路径插入单元格

Question

我有一个要在共享网络驱动器 \\Share\Projects 上的文件夹中搜索的 pdf 文件名。 pdf 将位于项目下的子文件夹之一中。然后我想将 pdf 的整个文件路径返回到一个单元格中（例如 \\Share\Projects\Subfolder\Another subfolder\thisone.pdf）。

我已经启动了代码，但不知道如何搜索文件系统：

Sub InsertPath()

    Dim PONumber As String
    PONumber = InputBox("PO Number:", "PO Number")

    'search for order
        Dim myFolder As Folder
        Dim myFile As File

        'This bit doesn't work
        Set myFolder = "\\Share\Projects"
        For Each myFile In myFolder.Files
            If myFile.Name = "PO" & PONumber & ".pdf" Then
                'I have absolutely no idea how to do this bit
            End If
        Next
End Sub

我是在正确的轨道上还是我的代码完全错误？

Answer 1

get list of subdirs in vba

稍微修改了上面的帖子。

Public Arr() As String
Public Counter As Long

Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
    For j = LBound(Arr) To UBound(Arr)
        MyFile = Dir(myArr(j) & "\*.pdf")
        Do While Len(MyFile) <> 0
        i = i + 1
            Cells(i, 1) = MyFile
            Cells(i, 2) = myArr(j)
            MyFile = Dir
        Loop
    Next j
Application.ScreenUpdating = True
End Sub

Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr

Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
    Counter = Counter + 1
    ReDim Preserve Arr(Counter)
    Arr(Counter) = sf.Path
    myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function

Answer 2

好吧，您的文件夹声明未针对文件系统对象设置，因此它无法找到该文件夹​​。而且因为它是一个网络位置，您可能需要先映射一个网络驱动器，以便它是一个安全链接。

所以这是您的代码的更新版本。

EDIT - 根据 OP 的条件。

    Dim PONumber As String
    Sub InsertPath()


    PONumber = InputBox("PO Number:", "PO Number")

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim Servershare As String
    ServerShare = "S:\"

    Dim Directory As Object
    Set Directory = fso.GetFolder(ServerShare)
    Subfolderstructure Directory
    End Sub
    Function Subfolderstructure(Directory As Object)

    For Each oFldr in Directory.SubFolders
    For Each FileName In oFldr.Files
        If FileName.Name = "PO" & PONumber & ".pdf" Then
            sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
            Exit For
        End If
    Next
    Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
    If isarray(sbfldrs) then 
    Subfolderstructure ofldr
    End if

    Next

    'Cleanup
    Set FileName = Nothing
    Set Directory = Nothing
    Set fso = Nothing
 End Function

我没有测试过这段代码。试试看，让我知道它是如何工作的。