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!!

Excel VBA get extended property for Image file

Hi

There are 287 extended property, to get Image info you can use following code:

Option Explicit

Sub GetImageInfo()

Dim i As Integer, SourceFldr

Dim c As Range, rng As Range

Dim sFile As Variant

Dim oWSHShell As Object



Dim fldr As FileDialog

Set fldr = Application.FileDialog(msoFileDialogFolderPicker)

Set oWSHShell = CreateObject("WScript.Shell")



With fldr

    .Title = "Select a Source Folder"

    .AllowMultiSelect = False

    .InitialFileName = oWSHShell.SpecialFolders("Desktop")

    If .Show <> -1 Then GoTo NextCode

    SourceFldr = .SelectedItems(1)

NextCode:

End With



Dim oShell: Set oShell = CreateObject("Shell.Application")

Dim oDir:   Set oDir = oShell.Namespace(SourceFldr)



i = 3

Range("A3:K5000").ClearContents



For Each sFile In oDir.Items

    Cells(i, 1).Value = oDir.GetDetailsOf(sFile, 0)   'File Name

    Cells(i, 2).Value = oDir.GetDetailsOf(sFile, 1)   'File Size

    Cells(i, 3).Value = oDir.GetDetailsOf(sFile, 2)   'File Type

    Cells(i, 4).Value = oDir.GetDetailsOf(sFile, 5)   'Date Created

    Cells(i, 5).Value = oDir.GetDetailsOf(sFile, 12)  'Date Taken

    Cells(i, 6).Value = oDir.GetDetailsOf(sFile, 31)  'Dimensions

    Cells(i, 7).Value = oDir.GetDetailsOf(sFile, 160) 'Bit Depth

    Cells(i, 8).Value = oDir.GetDetailsOf(sFile, 164) 'Height

    Cells(i, 9).Value = oDir.GetDetailsOf(sFile, 162) 'Width

    Cells(i, 10).Value = oDir.GetDetailsOf(sFile, 161)'Horizontal Resolution

    Cells(i, 11).Value = oDir.GetDetailsOf(sFile, 163)'Vertical Resolution

i = i + 1

Next

    Set oDir = Nothing

    Set oShell = Nothing

Cells.Columns.AutoFit

MsgBox "Done"

End Sub

See attachment.

Cheers!!

Vaibhav