Extract files in a folder containing contents in column A and move them to own folder

Good afternoon. I'm hoping someone call help me with something I'm working on. I have a file containing lots of documents, excel, pdf and word etc but their names contain a reference number.

I'd like to be able to enter a reference number in excel, then run a macro which would look for any files in a specific folder containing that reference number and group them together in their own folders and Ideally name the new folder with the reference number I entered in to excel. (there could be 3 or 4 documents in the main folder folder containing that specific reference number so I want to sperate them in to their own folders)

I hope this makes sense? Is it possible?

Thank you in advance.

Hi Lee,

See below, no error handling but a basic way to get to where you need to. Shorter versions of this code may be supplied by other users now the ball is rolling.

Code:

---

Sub FindFilesAndMove()   
    Dim MyFolder As String, MyFile As String, srchStr As String, DestFold As String, FSO As Object
 
    Set FSO = CreateObject("Scripting.Filesystemobject")
    srchStr = InputBox("Input search string")
    MyFolder = "C:\Users\JBloggs\Desktop\test\" '<<< change to suit
    DestFold = MyFolder & srchStr & "\"
    MkDir DestFold
    MyFile = Dir(MyFolder)
   
    Do While MyFile <> ""
        If InStr(MyFile, srchStr) Then
            FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFold & MyFile
        End If
        MyFile = Dir
    Loop
   
End Sub

---

Thank you so much for taking the time to help with this. Its much appreciated. This works perfectly, however rather than enter a single reference in a display box, could I list all the reference in column A and it would go through each one? Sorry if I didn't make that clear. Is there something I can change to do that? Much appreciated.

Maybe the below assuming the list starts in cell A2:

Code:

---

Sub FindFilesAndMove()   
    Dim MyFolder As String, MyFile As String, srchStr As String, DestFold As String, FSO As Object, rCell As Range
 
    Set FSO = CreateObject("Scripting.Filesystemobject")
    MyFolder = "C:\Users\jbloggs\Desktop\test\" '<<< change to suit
   
    For Each rCell In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Cells
        MyFile = Dir(MyFolder)
        srchStr = rCell.Value
        DestFold = MyFolder & srchStr & "\"
        MkDir DestFold
       
        Do While MyFile <> ""
            If InStr(MyFile, srchStr) Then
                FSO.MoveFile Source:=MyFolder & MyFile, Destination:=DestFold & MyFile
            End If
            MyFile = Dir
        Loop
    Next rCell
End Sub

---

Thank you! this works perfectly. You've saved me a massive headache. I would buy you a pint if I could. Instead if you want to nominate a charity I will send a donation to them as a thank you.

There is no need, but if you feel you must then it would be CLAPA as I was born with a cleft lip and palate.

Attachment 29339One good deed deserves another! I have made a donation to the charity (proof below). Thanks again for your help with this!

http://www.vbaexpress.com/forum/imag...AASUVORK5CYII=
http://www.vbaexpress.com/forum/imag...AASUVORK5CYII=

Thanks, that is very kind indeed :clap: