Option Explicit Public Sub MoveSelectedMessages() Dim objParentFolder As Outlook.Folder ' parent Dim newFolderName 'As String Dim strFilepath Dim xlApp As Object 'Excel.Application Dim xlWkb As Object ' As Workbook Dim xlSht As Object ' As Worksheet Dim rng As Object 'Range Set xlApp = CreateObject("Excel.Application") strFilepath = xlApp.GetOpenFilename If strFilepath = False Then xlApp.Quit Set xlApp = Nothing Exit Sub End If Set xlWkb = xlApp.Workbooks.Open(strFilepath) Set xlSht = xlWkb.Worksheets(1) Dim iRow As Integer iRow = 2 Set objParentFolder = Application.ActiveExplorer.CurrentFolder Dim parentname While xlSht.Cells(iRow, 1) <> "" parentname = xlSht.Cells(iRow, 1) newFolderName = xlSht.Cells(iRow, 2) If parentname = "Inbox" Then Set objParentFolder = Session.GetDefaultFolder(olFolderInbox) Else Set objParentFolder = objParentFolder.Folders(parentname) End If On Error Resume Next Dim objNewFolder As Outlook.Folder Set objNewFolder = objParentFolder.Folders(newFolderName) If objNewFolder Is Nothing Then Set objNewFolder = objParentFolder.Folders.Add(newFolderName) End If iRow = iRow + 1 ' make new folder the parent ' Set objParentFolder = objNewFolder Set objNewFolder = Nothing Wend xlWkb.Close xlApp.Quit Set xlWkb = Nothing Set xlApp = Nothing Set objParentFolder = Nothing End Sub