问基于服务器的规则，可将500+地址整理到约150个收件箱文件夹中

EN

fetch list of emails & their corresponding offices (both string lists)
set up folder variables
loop through messages, and move them eventually

Option Compare Text ' makes string comparisons case insensitive

Sub sortEmails()
'sorts the emails into folders

Dim msg As Outlook.MailItem
Dim itm As Object
Dim adress As String
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"

'1) fetch emails
GetEMailsFolders locIDs, emails, n

'1.5) fetch folder objects
'Create an instance of Outlook & inbox reference
Dim Inbox As Outlook.MAPIFolder
Dim outbox As Outlook.MAPIFolder


Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("email@host.com")
    objOwner.Resolve
'Set inbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Inbox = NS.Folders("email@host.com").Folders("Inbox")
Set outbox = NS.Folders("email@host.com").Folders("Sent Items")

Dim basefolder As Outlook.MAPIFolder
Dim bfName As String
bfName = "Offices" 'name of the folder for the offices
Set basefolder = MkDirConditional(Inbox.Folders("Project folder"), bfName)


'2)loop through inbox & outbox emails
Dim destination As Outlook.MAPIFolder
Dim fold(1 To 2) As Outlook.MAPIFolder
Set fold(1) = Inbox
Set fold(2) = outbox

Dim LocID As String
For Each fol In fold 'loop through inbox & outbox
    Debug.Print fol
    'reverse fo loop because otherwise moved messages modify indices of following messages
    For i = fol.Items.Count To 1 Step -1 'Each itm In fol.Items
        Set itm = fol.Items(i)
        If TypeName(itm) = "MailItem" Then ' others are AppointmentItem, MeetingItem, or TaskItem
            Set msg = itm
            'Debug.Print " " & msg.Subject
            If fol = Inbox Then
                ' there are two formats of email adrersses.
                If msg.SenderEmailType = "EX" Then 'check two kinds of email adress formats
                    adress = msg.Sender.GetExchangeUser().PrimarySmtpAddress
                ElseIf msg.SenderEmailType = "SMTP" Then 'SMTP case
                    adress = msg.SenderEmailAddress
                Else
                    Debug.Print "  neither EX nor SMTP" & msg.Subject;
                End If
                pos = Findstring(adress, emails) ' position in the email / standort list

            ElseIf fol = outbox Then

                For Each rec In msg.Recipients
                    Set pa = rec.PropertyAccessor
                    adress = pa.GetProperty(PR_SMTP_ADDRESS)
                    pos = Findstring(adress, emails)
                    If pos > 0 Then
                        Exit For
                    End If
                Next rec

            End If

            '4.5) if folder doesnt exist, create it
            '5) move message
            If pos > 0 Then
               'Debug.Print "  Its a Match!!"

               LocID = locIDs(pos)
               Set destination = MkDirConditional(basefolder, LocID)
               Debug.Print "  " & Left(msg.Subject, 20), adress, pos, destination
               msg.Move destination
            Else
               'Debug.Print "  not found!"
            End If
        Else
            'Debug.Print "  " & "non-mailitem", itm.Subject
        End If
    Next i
Next fol
End Sub

'//  Function - Check folder Exist
Private Function FolderExists(Inbox As Outlook.MAPIFolder, FolderName As String) As Boolean
    Dim Sub_Folder As MAPIFolder
    On Error GoTo Exit_Err
    Set Sub_Folder = Inbox.Folders(FolderName)
    FolderExists = True
        Exit Function
Exit_Err:
    FolderExists = False
End Function

Function MkDirConditional(basefolder As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
Debug.Print newfolder & " ";
If FolderExists(basefolder, newfolder) Then
    'folder exists, so just skip
    Set MkDirConditional = basefolder.Folders(newfolder)
    Debug.Print "exists already"
Else
    'folder doesnt exist, make it
    Set MkDirConditional = basefolder.Folders.Add(newfolder)

    Debug.Print "created"
End If
End Function

'function to compare two strings, min the option compare text at the top line
Function Findstring(str As String, arr As Variant) As Integer
'returns -1 if a string is not found, otherwise its index

Findstring = -1
Dim i As Integer
i = 1
For Each Item In arr
    'Debug.Print Item
    If str = Item Then
        Findstring = i
        Exit For
    End If
    i = i + 1
Next
End Function

' function to fetch the lists of emails and offices
Sub GetEMailsFolders(ByRef rng1 As Variant, ByRef rng2 As Variant, ByRef n As Variant)

'declare variables
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xExcelRange As Excel.Range
Dim TotalRows As Long

'declare SPOC xls file
xExcelFile = "adresses.xlsx"
'open the file
Set xExcelApp = CreateObject("Excel.Application")
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)

'extract LocIDs (column A), emails (column O) and thir number
n = xWs.Range(xWs.Range("A2"), xWs.Range("A2").End(xlDown)).Count ' works
ReDim rng1(1 To n) As Variant
ReDim rng2(1 To n) As Variant
For i = 1 To n
    rng1(i) = xWs.Cells(i + 1, 1)
    rng2(i) = xWs.Cells(i + 1, 15)
    'Debug.Print rng1(i), rng2(i)
Next
Debug.Print "done reading LocIDs & emails"

End Sub