Option Explicit
Option Base 1
Sub MovePDFsAndExcels()
' Array holding file names.
Dim asFilesList() As String
' Count of files found.
Dim iFilesFound As Long
' File number for looping file names.
Dim iFile As Long
' Directory into which files will be moved.
Dim sMoveToFolder As String
' Name of folder containing PDF files.
Dim sPDFFolderName As String
' Name of folder containing Excel files.
Dim sExcelFolderName As String
sPDFFolderName = "PDF Files"
sExcelFolderName = "Excel Files"
' Default folder is the one that "Thisworkbook" is in.
sMoveToFolder = ThisWorkbook.Path & "\"
' If user specified an alternate folder (in worksheetnamed Control) then use that folder's name.
With Worksheets("Control")
If .Range("AlternateFolder").Value <> "" _
Then
sMoveToFolder = .Range("AlternateFolder").Value
If Right(sMoveToFolder, 1) <> "\" Then sMoveToFolder = sMoveToFolder & "\"
' Check alternate folder exists.
If Not CheckFolderExists(sMoveToFolder) _
Then
' If alternate folder does not exist then tell user then exit sub.
MsgBox "The folder named" & Chr(10) & sMoveToFolder & Chr(10) & "does not exist."
Exit Sub
End If
End If
End With
' Fill array with file names
asFilesList = GetFilesInDir(sMoveToFolder)
' Get count of files found.
iFilesFound = UBound(asFilesList)
For iFile = 1 To iFilesFound
If UCase(Right(asFilesList(iFile), 3)) = "PDF" _
Then
' If PDF files directory does not exist then create it.
If Not CheckFolderExists(sMoveToFolder, sPDFFolderName) Then MkDir (sMoveToFolder & sPDFFolderName)
' Move the PDF file to the PDF files folder.
Name sMoveToFolder & asFilesList(iFile) As sMoveToFolder & sPDFFolderName & "\" & asFilesList(iFile)
ElseIf UCase(asFilesList(iFile)) Like "*.XLS*" _
Then
' If Excel files directory does not exist then create it.
If Not CheckFolderExists(sMoveToFolder, sExcelFolderName) Then MkDir (sMoveToFolder & sExcelFolderName)
' Do not/Cannot move "this workbook" file.
If asFilesList(iFile) <> ThisWorkbook.Name _
Then
' Move the Excel file to the Excel files folder.
Name sMoveToFolder & asFilesList(iFile) As sMoveToFolder & sExcelFolderName & "\" & asFilesList(iFile)
End If
End If
Next iFile
End Sub
Option Explicit
'Based on https://www.automateexcel.com/vba/file-exists/
Function CheckFolderExists(psDir, Optional psFolderName As String = "")
Dim strFolderName As String
Dim strFolderExists As String
If Right(psDir, 1) <> "\" Then psDir = psDir & "\"
If psFolderName <> "" _
Then
If Right(psFolderName, 1) <> "\" Then psFolderName = psFolderName & "\"
strFolderName = psDir & psFolderName
Else
strFolderName = psDir
End If
strFolderExists = Dir(strFolderName, vbDirectory)
If strFolderExists = "" Then
CheckFolderExists = False
Else
CheckFolderExists = True
End If
End Function
Option Explicit
Option Base 1
'Based on https://stackoverflow.com/questions/31414106/get-list-of-excel-files-in-a-folder-using-vba
'Returns an array containing the file names.
Function GetFilesInDir(ByVal sPath As String, _
Optional ByVal sFilter As String) As String()
' Dynamically sized array for file names.
Dim aFileNames() As String
ReDim aFileNames(1)
Dim sFile As String
Dim nCounter As Long
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If sFilter = "" Then
sFilter = "*.*"
End If
' Call with path "initializes" the dir function and returns the first file
sFile = Dir(sPath & sFilter)
nCounter = 1
' Loop folder until there is no file name returned.
Do While sFile <> ""
'store the file name in the array
aFileNames(nCounter) = sFile
'subsequent calls without param return next file
sFile = Dir
'make sure your array is large enough for another
nCounter = nCounter + 1
If nCounter > UBound(aFileNames) Then
'preserve the values and grow by reasonable amount for performance
ReDim Preserve aFileNames(UBound(aFileNames) + 255)
End If
Loop
' Truncate the array to correct size
If nCounter < UBound(aFileNames) Then
ReDim Preserve aFileNames(1 To nCounter)
End If
' Return the array of file names.
GetFilesInDir = aFileNames()
End Function
Option Explicit
Sub SelectFolder()
'PURPOSE: Have User Select a Folder Path and Store it to a variable
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim FldrPicker As FileDialog
Dim sMyFolder As String
' Have User Select Folder to Save to with Dialog Box
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
sMyFolder = .SelectedItems(1) & "\"
End With
If CheckFolderExists(sMyFolder) _
Then
[Control].Range("AlternateFolder").Value = sMyFolder
End If
End Sub