Attribute VB_Name = "MoveSubfolder"
Option Explicit

Sub MoveSubfolder()
    ' Pick a folder and moves Items in Subfolders by year

    Dim objFolder As MAPIFolder
    Set objFolder = Outlook.GetNamespace("MAPI").PickFolder

    Dim oMsgColl As Items
    Dim objItem As Object  ' normally Mailitem, but not always
    Set oMsgColl = objFolder.Items
    Set objItem = oMsgColl.GetFirst
    Do While (Not objItem Is Nothing)
        Debug.Print "Found:" & objItem.ReceivedTime & " - " & objItem.subject
        On Error Resume Next
        If objFolder.Folders(objFolder.Name & "-" & CStr(Year(objItem.ReceivedTime))) Is Nothing Then
            Debug.Print "Neuer Ordner angelegt: " & objFolder.Name & "-" & CStr(Year(objItem.ReceivedTime))
            objFolder.Folders.Add (objFolder.Name & "-" & CStr(Year(objItem.ReceivedTime)))
        End If
        Err.Clear: On Error GoTo 0
        objItem.Move (objFolder.Folders(objFolder.Name & "-" & CStr(Year(objItem.ReceivedTime))))
        Set objItem = oMsgColl.GetNext
    Loop
End Sub