Search and move multiple Outlook folders using vba

Question

I need to make some order thru my cases and need to move all the closed ones to a specific folder.
I managed to find a way, sort of, but this solution only moves 1 folder at a time and the thing is there are >200 cases which needs to be moved.
All the folders are in a shared e-mail account and the way I can identify the folders that needs to be moved is by theirs last 6 characters found in the end of the folder name, which is actually an unique ID. Specifically a folder is named this way: "XX.ddmmyy.string.string.XX.ID"
The only data I have for identifying and moving this folders is a list with IDs which came in a excel file like that:

123456
123457
123458
and so on...

I think what I am searching for is a vector, but don't have much experience with, so could you please help me figure a way to move to insert all the criterias at once to move the folders and to identify the IDs which couldn't be found/moved?

Here is what I have so far (search for the entered ID in the text box, loops thru folders, move it to a specific one and displays a message box). I run the FindFolder macro.

Private myFolder As Outlook.MAPIFolder
Private MyFolderWild As Boolean
Private MyFind As String

Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders
Dim myNewFolder As Outlook.folder
Dim olApp As Outlook.Application
Dim NS As NameSpace
Dim olDestFolder As Object
Dim folder_name As String

Set myFolder = Nothing
MyFind = ""
MyFolderWild = False

Name = "*" & InputBox("Enter the Folder Name that you would like to find:")
If Len(Trim$(Name)) = 0 Then Exit Sub
MyFind = Name

MyFind = LCase$(MyFind)
MyFind = Replace(MyFind, "%", "*")
MyFolderWild = (InStr(MyFind, "*"))

Set Folders = Application.Session.Folders
LoopFolders Folders

If Not myFolder Is Nothing Then
If MsgBox("Do you want to move this folder ?" & vbCrLf &   myFolder.folderPath, vbQuestion Or vbYesNo, "Found your Folder:") = vbYes Then
    Set Application.ActiveExplorer.CurrentFolder = myFolder
    Set olApp = Application
    Set NS = olApp.GetNamespace("MAPI")
    Set olDestFolder = NS.Folders("[email protected]").Folders("Inbox").Folders("cleanup")
    myFolder.MoveTo olDestFolder
Call Repeat
End If
Else
MsgBox "The folder you were looking for can not be found.", vbCritical, "Folder NOT found:"
End If
End Sub


Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean

For Each F In Folders
If MyFolderWild Then
  Found = (LCase$(F.Name) Like MyFind)
Else
  Found = (LCase$(F.Name) = MyFind)
End If

If Found Then
  Set myFolder = F
  Exit For
Else
  LoopFolders F.Folders
  If Not myFolder Is Nothing Then Exit For
End If
Next
End Sub


Sub Repeat()
If MsgBox("The folder has been succesfully moved." & vbCrLf & "Do you want to move another folder?", vbQuestion Or vbYesNo) = vbYes Then
Call FindFolder
Else
End
Exit Sub
End If
End Sub

Many thanks!

Answer 1

I recommend to type the list (of folders to move) in Excel. Then add the following code to Excel

Public Sub MoveFolders(rInputRange As Range)

    Dim rCell As Range

    For Each rCell In Selection
        rCell.Offset(0, 1) = MoveFolder("*" & rCell)
    Next rCell

End Sub

Public Function MoveFolder(sSearchName As String) As Boolean

    Const DESTINATION_FOLDER As String = "linkedin"

    Dim oFoundFolder        As Outlook.Folder
    Dim oDestinationFolder  As Outlook.Folder

    Set oFoundFolder = FindFolderRecursive(sSearchName)

    If oFoundFolder Is Nothing Then
        MoveFolder = False
    Else
        Set oDestinationFolder = FindFolderRecursive(DESTINATION_FOLDER)
        oFoundFolder.MoveTo oDestinationFolder
        MoveFolder = True
    End If

End Function

Public Function FindFolderRecursive(sSearchName As String, Optional oFolder As Folder = Nothing) As Folder

    Dim oSubFolder          As Outlook.Folder
    Dim oFolders            As Outlook.Folders

    If oFolder Is Nothing Then
        Set oFolders = Outlook.Application.Session.Folders
    Else
        Set oFolders = oFolder.Folders
    End If

    For Each oSubFolder In oFolders
        If LCase(oSubFolder.Name) Like LCase(sSearchName) Then
            Set FindFolderRecursive = oSubFolder
            Exit Function
        Else
            Set FindFolderRecursive = FindFolderRecursive(sSearchName, oSubFolder)
            If Not FindFolderRecursive Is Nothing Then Exit Function
        End If
    Next oSubFolder

End Function

Make sure to reference the outlook library.

If you select the list, then you can execute the code for all folders by using the following code in the immediate window

MoveFolders Selection