excelnovice_2022
New Member
- Joined
- Jun 22, 2022
- Messages
- 1
- Office Version
- 365
- Platform
- Windows
I am looking for a script/code for a macro that will, based on certain criteria which is contained in an excel spreadsheet, sort and move a large volume of PDF files from a general folder on One Drive into individual folders (also on One Drive). I tried to look at a similar question & answer to this thread [Move Files To Dynamic Folders Based On Cell Value (linked)], but it doesn't provide for my direct need and I am having a hard time figuring out how to correctly tweak my script (again, definitely a novice and wanting to learn more!). Any help would be appreciated!!
I have approximately 400 PDF files that all start with "ABC" and then list a unique code number (e.g., "ABC 0123456789", "ABC 1234567890", "ABC 2345678901" and so on). I want to automatically sort and move individual PDF files based on their unique code number (listed in Column E of my excel spreadsheet) into individual corresponding folders, which were already created and named according to a reference number ("1", "2", "3", so on; listed in Column A of my excel spreadsheet).
The script I reviewed to see if I could figure out how to tweak it (from Move Files to Dynamic Folders Based on Cell Value, linked above):
Sub MyMoveMacro()
Dim fpick As Object
Dim fldr As String
Dim wb As Workbook
Dim newFldr As String
Dim newFldrExists As String
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Application.ScreenUpdating = False
' Browse for folder
Set fpick = Application.FileDialog(4)
With fpick
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
fldr = .SelectedItems(1)
End With
If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
MsgBox "fldr is: " & fldr
' Set file system objects
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(fldr) 'Initialize folder
Set oFiles = oFolder.Files
' Loop through all Excel files in the folder
For Each oFile In oFiles
If (oFile Like "*.xls*") Then
' Open file
Set wb = Workbooks.Open(Filename:=oFile)
' Get new folder name from cell E8
newFldr = fldr & Sheets("Order Template").Range("E8").Value
If Right(newFldr, 1) <> "\" Then newFldr = newFldr & "\"
MsgBox "newFldr is: " & newFldr
' Check to see if folder exists
newFldrExists = Dir(newFldr, vbDirectory)
If newFldrExists = "" Then
' Create new directory
MkDir newFldr
End If
' Save file to new directory
wb.SaveAs Filename:=newFldr & wb.Name
' Close workbook
wb.Close
End If
Next oFile
' Delete Excel files in original location
Kill fldr & "*.xls*"
Application.ScreenUpdating = True
MsgBox "Macro Complete!"
End Sub
I have approximately 400 PDF files that all start with "ABC" and then list a unique code number (e.g., "ABC 0123456789", "ABC 1234567890", "ABC 2345678901" and so on). I want to automatically sort and move individual PDF files based on their unique code number (listed in Column E of my excel spreadsheet) into individual corresponding folders, which were already created and named according to a reference number ("1", "2", "3", so on; listed in Column A of my excel spreadsheet).
The script I reviewed to see if I could figure out how to tweak it (from Move Files to Dynamic Folders Based on Cell Value, linked above):
Sub MyMoveMacro()
Dim fpick As Object
Dim fldr As String
Dim wb As Workbook
Dim newFldr As String
Dim newFldrExists As String
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Application.ScreenUpdating = False
' Browse for folder
Set fpick = Application.FileDialog(4)
With fpick
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
fldr = .SelectedItems(1)
End With
If Right(fldr, 1) <> "\" Then fldr = fldr & "\"
MsgBox "fldr is: " & fldr
' Set file system objects
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(fldr) 'Initialize folder
Set oFiles = oFolder.Files
' Loop through all Excel files in the folder
For Each oFile In oFiles
If (oFile Like "*.xls*") Then
' Open file
Set wb = Workbooks.Open(Filename:=oFile)
' Get new folder name from cell E8
newFldr = fldr & Sheets("Order Template").Range("E8").Value
If Right(newFldr, 1) <> "\" Then newFldr = newFldr & "\"
MsgBox "newFldr is: " & newFldr
' Check to see if folder exists
newFldrExists = Dir(newFldr, vbDirectory)
If newFldrExists = "" Then
' Create new directory
MkDir newFldr
End If
' Save file to new directory
wb.SaveAs Filename:=newFldr & wb.Name
' Close workbook
wb.Close
End If
Next oFile
' Delete Excel files in original location
Kill fldr & "*.xls*"
Application.ScreenUpdating = True
MsgBox "Macro Complete!"
End Sub