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

嗯，您的文件夹声明不是针对文件系统对象设置的，因此无法找到该文件夹。由于它是网络位置，因此您可能需要先映射网络驱动器，以使其成为安全链接。

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

编辑 - 符合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

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

Answer 2

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

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

2 个答案: