Search and move multiple Outlook folders using VBA

Hi,
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: "string.ddmmyy.string.string.string.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 criteria 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.


Many thanks!


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_account").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 successfully moved." & vbCrLf & "Do you want to move another folder?", vbQuestion Or vbYesNo) = vbYes Then
Call FindFolder
Else
End
Exit Sub
End If
End Sub

Having looked at your process, this already appears to do what you require as long as you wish to retain the prompt to confirm that you wish to move the folder. I note also that your InputBox Cancel cannot work, because the condition required to exit cannot exist. You would need for that

Code:

---

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

---

If you are happy to lose the confirmation prompts then you need instead to introduce a loop to read the numeric values into the variable 'Name' in place of the inbox and process those values.

Let's assume that you have a worksheet with a single column (A) with a header row and the numbers to be processed in that column. You could then use a function to read that column and process the found numbers

Code:

---

Option Explicit

Private myFolder As Outlook.MAPIFolder
Private MyFolderWild As Boolean
Private MyFind As String
Private Const strWorkBook As String = "C:\Path\IDList.xlsx"        ' The full path of the ID number List workbook
Private Const strSheet As String = "Sheet1"        'The name of the worksheet
Private Const strAccount As String = "email_account" 'The account to process

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
Dim iCols As Long, iRows As Long
Dim Arr() As Variant

    Arr = xlFillArray(strWorkBook, strSheet)

    For iRows = 0 To UBound(Arr, 1)
        For iCols = 0 To UBound(Arr, 2)
            Set myFolder = Nothing
            MyFind = ""
            MyFolderWild = False
            Name = Arr(0, iCols)
            If Len(Trim$(Name)) = 0 Or _
              Len(Trim$(Name)) > 6 _
              Or Not IsNumeric(Name) 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
                Set Application.ActiveExplorer.CurrentFolder = myFolder
                Set olApp = Application
                Set NS = olApp.GetNamespace("MAPI")
                Set olDestFolder = NS.Folders(strAccount).Folders("Inbox").Folders("cleanup")
                myFolder.MoveTo olDestFolder
            End If
        Next iCols
    Next iRows
lbl_Exit:
    Exit Sub
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

Private Function xlFillArray(strWorkBook As String, _
                            strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strWorksheetName = strWorksheetName & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkBook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

---

Thank you so much gmayor! Works flawless! :-)