Create Folders and Subfolders in Outlook Folder Structure - Choose a Origim Folder and Create the same Subfolders in the Destination

VBAOutlookCreateFoldersSubfolders.bas

Sub CreateFolders()
    Dim olNS As NameSpace
    Dim olFolder As Folder
    Dim OlNewFolder As Folder
    Dim olNewFolders As Folders
    Dim olItems As Items
    Dim olItem As MailItem
    Dim strName As String
    Dim i As Long
    
    Set olNS = Application.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Set OlNewFolder = olNS.PickFolder
    Set olNewFolders = OlNewFolder.Folders
    Set olItems = olFolder.Items
    On Error Resume Next
    For i = olItems.Count To 1 Step -1
    Set olItem = olItems(i)
    strName = olItem.Sender
    olNewFolders.Add strName, olFolderInbox
    olItem.Move olNewFolders(strName)
    Next i
lbl_Exit:
    Exit Sub
End Sub