Public Sub autoIn(itm As Outlook.MailItem)
    Dim oApp As New Outlook.Application
    Dim NSpace As NameSpace
    Dim senderDoman As String
    Dim keySender As String

        On Error Resume Next
        Set NSpace = oApp.GetNamespace("MAPI")
        keySender = LCase(Split(itm.SenderEmailAddress, "@")(1))
            Select Case keySender
                Case "mail.ru"
                    senderDoman = "e" & LCase(Split(itm.SenderEmailAddress, "@")(0))
                Case "yandex.ru"
                    senderDoman = "e" & LCase(Split(itm.SenderEmailAddress, "@")(0))
                Case "gmail.com"
                    senderDoman = "e" & LCase(Split(itm.SenderEmailAddress, "@")(0))
                Case "bk.ru"
                    senderDoman = "e" & LCase(Split(itm.SenderEmailAddress, "@")(0))
                Case ""

                Case Else
                    senderDoman = LCase(Split(itm.SenderEmailAddress, "@")(1))
            End Select
            Call moveMSG(itm, LCase(senderDoman), itm.SenderEmailAddress, NSpace, 6)
End Sub

Sub moveMSG(oMail As Outlook.MailItem, iSender, iName, iNSpace As NameSpace, o As Integer)
    Dim oApp As New Outlook.Application
    Dim aFolderName As Outlook.Folder
        
    aName = xmlNodeName("mail", iSender, iName)
        
    On Error Resume Next
    Set aFolderName = iNSpace.GetDefaultFolder(o).Folders.Item(aName)
    If aFolderName Is Nothing Then
        Set aFolderName = iNSpace.GetDefaultFolder(o).Folders.Add(aName)
    End If
    
    oMail.Move iNSpace.GetDefaultFolder(o).Folders(aName)
End Sub

Function xmlNodeName(xmlFile, Sender, Name)
    ' функция записи в  XML
    Dim corSender As String
    Dim xmlDoc As MSXML2.DOMDocument60
    Set xmlDoc = New MSXML2.DOMDocument60
    Dim Node As MSXML2.IXMLDOMNode
    Dim rootXML As MSXML2.IXMLDOMNode
    Dim iFolder As String
    Dim xmlEle As MSXML2.IXMLDOMNode
    
    corSender = CorrectName(Sender)
    xmlDoc.Load ("C:\Forms\sys\" & xmlFile & ".xml") ' путь к файлу...
    
    On Error Resume Next
    Set Node = xmlDoc.SelectSingleNode("//" & xmlFile & "/" & corSender)
        
    If Node Is Nothing Then
        iFolder = InputBox("Введите имя папки для " & Name & "." & vbCrLf & "Примечание: Спам - Прочее", "Новый адрес")
        If iFolder = "" Then Exit Function
        Set rootXML = xmlDoc.SelectSingleNode(xmlFile)
        Set xmlEle = xmlDoc.createElement(corSender)
        rootXML.appendChild xmlEle
        Set Node = xmlDoc.SelectSingleNode("//" & xmlFile & "/" & corSender)
        Node.text = iFolder
        rootXML.appendChild xmlDoc.createTextNode(vbCrLf)
        xmlDoc.Save ("C:\Forms\sys\" & xmlFile & ".xml")
    End If
    xmlNodeName = Node.text
End Function

Function CorrectName(text)
    Dim s$, i&
    s = "-~:!/\#$%^&*=|`@"""
    For i = 1 To Len(s)
        text = Replace(text, Mid(s, i, 1), "_")
    Next
    CorrectName = text
End Function

<?xml version="1.0" encoding="utf-8"?>
<mail>
    <eorgtm.ru>ОРГТМ</eorgtm.ru>
    <eelo>УППК</eelo>
    <eenerg.ru>ЭнергоН</eenerg.ru>
    <e21_277>1.Личное</e21_277>
</mail>