Find file and insert path into cell

Question

I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).

I have started the code but can't figure out how to search a file system:

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

Am I on the right track or is my code completely wrong?

I think this post will help you get a list of the files [http://stackoverflow.com/questions/20219362/excel-vba-to-list-files-in-folder-and-subfolder-with-path-to-txt-file](http://stackoverflow.com/questions/20219362/excel-vba-to-list-files-in-folder-and-subfolder-with-path-to-txt-file) — Nybbe, Mar 13 '14 at 22:30

Rich · Answer 1 · 2014-03-14T04:34:30.130

0

Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.

So here's an updated version of your code.

EDIT - to OP's conditions.

    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

I have not tested this code. Try it out and let me know how it works.

edited Mar 14 '14 at 04:34

answered Mar 13 '14 at 22:51

Rich

4,134
3
26
45

Two things I'd modify in your code: 1. Use variable types in declaration; 2. Exit the `For` loop after you found a matching file name. – Kapol Mar 13 '14 at 23:18
Thanks Rich, I'll test it shortly. The network drive actually is mapped under "S:\". So you recommend I change "\\Share\Projects" to "S:\" or is it enough to map the drive and use "\\Share\Projects"? – matt9292 Mar 13 '14 at 23:58
If its permanently mapped, just set the servershare = s:\ and delete the network object activations and you should be good to go. – Rich Mar 14 '14 at 00:31
@user2967539 ok dude. I updated the code to your mapped drive. Give that a swing. – Rich Mar 14 '14 at 02:45
Rich, it's jumping from the "For Each FileName..." line straight to the cleanup section. I don't think it's searching subfolders, I think it's just looking at the main directory of the share (which has no files directly inside it) – matt9292 Mar 14 '14 at 03:24
Oh yeah, one sec. Ill fix the code. Didn't realize u wanted all subfolders. Sorry, on the phone. Takes a bit – Rich Mar 14 '14 at 03:30
That's great, I think it's nearly there. It's a bit much to ask of Excel probably, but do you know if it search through multiple levels of subfolders? – matt9292 Mar 14 '14 at 03:50

score 0 · Answer 2 · edited May 23 '17 at 12:28

get list of subdirs in vba

slighly modified the above post.

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

Find file and insert path into cell

2 Answers2