Macro to move subfolder outlook

[cranebill]

I need a macro thet will move the highlighted folder to a different specified folder. I am manually moving them and since I cannot select more than one folder building a macro seems key...

any ideas?

 

[WinblowsME]

Here's something to get you started.

Sub Copy_Folder()
   Dim ns As Outlook.NameSpace
   Dim source_folder As Outlook.MAPIFolder
   Dim target_folder As Outlook.MAPIFolder
   Dim curr_folder As Outlook.MAPIFolder
   Dim folder_name As String
   
   Set ns = GetNamespace("MAPI")
   
   For Each curr_folder In ns.Folders
      If InStr(1, UCase(curr_folder.Name), "MAILBOX") > 0 Then
         folder_name = curr_folder.Name
         Exit For
      End If
   Next
   
   On Error GoTo ERR_HANDLER
   
   Set source_folder = ns.Folders.item(folder_name).Folders.item("Temp")
   Set target_folder = ns.Folders.item(folder_name).Folders.item("Temp1")
   
   ' Copies Temp to Temp1
   source_folder.CopyTo target_folder
   
   Set source_folder = Nothing
   Set target_folder = Nothing
   Set ns = Nothing
   Exit Sub
ERR_HANDLER:
   MsgBox Err.Description
   
   Set source_folder = Nothing
   Set target_folder = Nothing
   Set ns = Nothing
End Sub