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