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"
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
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
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
Else
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