Search and move multiple Outlook folders using VBA

[Cosmin]

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

[gmayor]

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

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



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

[Cosmin]

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