VBA - Moving files based on their filenames

[barbs706]

Hi all.

I'm looking for a script that can tidy up my hand written project notes that I scan to PDF with a photocopier.

Currently, I have my projects file structure as follows:
Z:\Admin\Projects\Joe Bloggs\B1234
(Joe Bloggs being the client name, B1234 being the project number)

The photocopier scans location is:
Z:\Admin\Scans

Every time I scan a hand written note, I set the PDF filename to the project number.
Instead of having to manually cut and paste the scanned PDF files to their relevant project folders, I'd like to automate the process.

So basically, I need some thoughts on some code that can look into the Scans folder, note its filename, search Z:\Admin\Projects for a folder that matches the PDF filename, and move the file into that folder.

I've found a few strings of code, but I'm falling short on searching the projects folder!

Hope that's clear enough!

Many thanks.

 

[Fluff]

Untested, but how about

Sub SearchFolder()

    Dim FldrPth As String
    Dim InitPth As String
    Dim FName As String
    Dim Fldr As String
    Dim Fnd As Range
    Dim Msg As String
    
    InitPth = "Z:\Admin\"
    
    FName = Dir(InitPth & "Scans\" & "*.txt")
    Do While Len(FName) > 0
        Set Fnd = Range("A1", Range("A1").End(xlDown)).Find(Left(FName, InStr(FName, ".") - 1), , , xlWhole, , , True, , False)
        If Not Fnd Is Nothing Then
            FldrPth = InitPth & "Projects\" & Fnd.Offset(, 1).Value & "\" & Fnd.Value & "\"
        Else
            Msg = Msg & vbLf & FName
        End If
        FileCopy InitPth & "Scans\" & FName, FldrPth & FName
        Kill InitPth & FName
        
        FName = Dir
    Loop
    If Not Msg = "" Then MsgBox Msg & vbLf & "Not Found"
End Sub

as this deletes files after copying them, I'd suggest creating some test files.
You will also need to set up a sheet containing projects in Col A & clients in col B (the sheet needs to be active when you run this). Like

Excel 2013 32 bit
	A	B
1	B1234	Joe Bloggs
2	B1235	Pete Snodgrass
3	B1236	An Other
4	B1237	Yet An Other
Sheet2

 

[barbs706]

Thanks for this Fluff.

I was getting an error on Kill InitPth & FName. However I've commented this out and it works well.

Is there a way of getting the code to run without being reliant on information on cells? Such as a blank workbook?

 

[Fluff]

The Kill line should have been

Kill InitPth & "Scans\" & FName

There probably is a way to search through multiple folders & sub folders, but I'm not sure how. I'll have a look & see what I can come up with.

 

[Fluff]

Have a go with this

Sub SearchAllFolders()

    Dim Fso As Object
    Dim Fldr As Object, sbFldr1 As Object, sbFldr2 As Object
    Dim Msg As String, Fname As Object

    With CreateObject("scripting.dictionary")
        Set Fso = CreateObject("scripting.filesystemobject")
        Set Fldr = Fso.GetFolder("Z:Admin\Projects\")
        For Each sbFldr1 In Fldr.SubFolders
            For Each sbFldr2 In sbFldr1.SubFolders
                .Add Right(sbFldr2, Len(sbFldr2) - InStrRev(sbFldr2, "\")), sbFldr2
            Next sbFldr2
        Next sbFldr1
        Set Fldr = Fso.GetFolder("Z:Admin\Scans\")
        For Each Fname In Fldr.files
            If .exists(Left(Fname.Name, Len(Fname.Name) - 4)) Then
                Fname.Move .Item(Left(Fname.Name, Len(Fname.Name) - 4)) & "\"
            Else
                Msg = Msg & vbLf & Fname.Name
            End If
        Next Fname
    End With
    MsgBox Msg & " Folder not found"
End Sub