Excel VBA move PDF files to specific folder

Hi

Lets say you have your employee files or customer files in a single folder with employee name /customer name in the beginning (say 1st six digit).

Now you want to move all of them to individual employee / customer wise folder?

Tons of thousands of employees /customers & cant do manually.. Here goes macro...

Sub move_PDF()

Dim fldr As FileDialog

Dim emp As String, SourceFldr As String, DestFldr As String

Dim FileToOpen As Variant



Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

With fldr

    .Title = "Select a Source Folder"

    .AllowMultiSelect = False

    .InitialFileName = strPath

    If .Show <> -1 Then GoTo NextCode

    SourceFldr = .SelectedItems(1) & "\"

NextCode:

End With



With fldr

    .Title = "Select a Destination Folder"

    .AllowMultiSelect = False

    .InitialFileName = strPath

    If .Show <> -1 Then GoTo NextCode2

    DestFldr = .SelectedItems(1) & "\"

NextCode2:

End With



FileToOpen = Dir(SourceFldr & "*.pdf")



Do While FileToOpen <> ""



'check if folder exists

Dim FSO As Object

Set FSO = CreateObject("scripting.filesystemobject")

emp = Left(FileToOpen, 6)

If FSO.FolderExists(DestFldr & emp) = False Then

MkDir DestFldr & emp

End If

    

'Move file

Name SourceFldr & FileToOpen As DestFldr & emp & "\" & FileToOpen

FileToOpen = Dir

Loop



MsgBox "Files moved"

End Sub

See Attachment

Cheers!!