Option Explicit
Public Sub Move_Folders()
Dim workbookFileName As String
Dim workbookOpened As Boolean
Dim ExcelApp As Object, ExcelWb As Object
Dim lastRow As Long, r As Long
Dim outSourceFolder As Outlook.MAPIFolder
Dim outDestFolder As Outlook.MAPIFolder
Const cExcelWorkbook As String = "C:\path\to\Excel Workbook.xlsx" 'CHANGE THIS
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set ExcelApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
workbookFileName = Dir(cExcelWorkbook)
If workbookFileName <> vbNullString Then
Set ExcelWb = Nothing
workbookOpened = False
On Error Resume Next
Set ExcelWb = ExcelApp.Workbooks(workbookFileName)
If ExcelWb Is Nothing Then
Set ExcelWb = Workbooks.Open(cExcelWorkbook)
workbookOpened = True
End If
On Error GoTo 0
Else
MsgBox cExcelWorkbook & " not found"
Exit Sub
End If
ExcelApp.Visible = True
Application.ActiveExplorer.Activate
With ExcelWb.Worksheets("MoveFolders")
lastRow = .cells(.rows.count, "A").End(xlUp).Row
For r = 2 To lastRow
Set outSourceFolder = Get_Folder(.cells(r, "A").Value)
Set outDestFolder = Get_Folder(.cells(r, "B").Value)
If Not outSourceFolder Is Nothing And Not outDestFolder Is Nothing Then
outSourceFolder.MoveTo outDestFolder
MsgBox "Row " & r & vbCrLf & _
outSourceFolder.folderPath & vbCrLf & _
"moved to " & vbCrLf & _
outDestFolder.folderPath
Else
MsgBox "Row " & r & vbCrLf & _
IIf(outSourceFolder Is Nothing, "Source folder '" & .cells(r, "A").Value & "' not found" & vbCrLf, "") & _
IIf(outDestFolder Is Nothing, "Destination folder '" & .cells(r, "A").Value & "' not found" & vbCrLf, "")
End If
Next
End With
If workbookOpened Then
ExcelWb.Close SaveChanges:=False
End If
End Sub
Private Function Get_Folder(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
'Search for the specified folder path starting at the optional MAPI start folder.
'
'If outStartFolder is specified then start in that folder and search for the specified folder path.
'If outStartFolder is not specified then the search starts at the specified folder path. The folder path
'can start with a top-level folder by prepending the folder path with "\\". Folder names are separated by "\".
'
'Examples:
' "\\Account Name\Folder1\Subfolder1\Sub-Subfolder1" - folders in main (active) top-level folder
' "\\Archive Folders\Folder1\Subfolder1" - folders in archive folder
' "Folder1\Subfolder1\Sub-Subfolder1" - folders in main (active) top-level folder
'
'If the whole subfolder path is found this function returns the last subfolder as a MAPIFolder object, otherwise
'it returns Nothing
Dim NS As NameSpace
Dim outFolder As MAPIFolder
Dim outFolders As folders
Dim folders As Variant
Dim i As Long
Set NS = Application.GetNamespace("MAPI")
If outStartFolder Is Nothing Then
If Left(folderPath, 2) = "\\" Then
'folderPath starts with a top level folder ("\\Folder name\xxx\yyy"), so look for that
'folder and if found set outStartFolder to it
folders = Split(Mid(folderPath, 3), "\")
Set outFolders = NS.folders
Set outStartFolder = Nothing
i = 1
While i <= outFolders.count And outStartFolder Is Nothing
Set outFolder = outFolders(i)
If outFolder.Name = folders(0) Then Set outStartFolder = outFolder
i = i + 1
Wend
i = 1 'match folder paths from 2nd folder in path
Else
'Top level folder not specified, so start subfolders search at parent folder of the Inbox
Set outStartFolder = NS.GetDefaultFolder(olFolderInbox).Parent
folders = Split(folderPath, "\")
i = 0
End If
Else
folders = Split(folderPath, "\")
i = 0
End If
Set outFolder = outStartFolder
While i <= UBound(folders) And Not outFolder Is Nothing
If folders(i) <> "" Then
Set outFolder = Nothing
On Error Resume Next
Set outFolder = outStartFolder.folders(folders(i))
On Error GoTo 0
Set outStartFolder = outFolder
End If
i = i + 1
Wend
Set Get_Folder = outFolder
End Function
