https://www.reddit.com/r/vba/comments/60qgrr/help_move_emails_based_on_subject/

i have made progress on my script (before, i had nothing!) and now i feel I'm closing in on the final stages, but i need your help!

toward the bottom of my code, you can see a couple comments that i still need to complete

1) don't move the last unread email

i have it skipping the unread emails, but i need to somehow group emails on case number and only make changes on groups of 2 or more

2) set destination folder

i have the destination folder in a dictionary as this:

key = 12345
value = \folder\sub\12345

and i was thinking about splitting on "\" to get each folder - the number of sub folders varies - but I'm not sure on the logic of how to turn that into this:

Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("folder").Folders("sub").Folders("12345")

here's what I've got so far (any help or suggestions for improvement welcome!):

Function toArray(col As Collection)
    Dim arr() As Variant
    ReDim arr(1 To col.count) As Variant
    For i = 1 To col.count
        arr(i) = col(i)
    Next
    toArray = arr
End Function


Sub ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, ByRef col As Collection)
    Dim olFolder As Outlook.MAPIFolder

    For Each olFolder In MyFolder.Folders
        col.Add (String(Level, "§") & olFolder.Name)
        If olFolder.Folders.count > 0 Then
            Call ListFolders(olFolder, Level   1, col)
        End If
    Next
End Sub

Function TestRegExp(myString As String, pattern As String)
    Dim objRegExp As RegExp

    Set objRegExp = New RegExp
    objRegExp.pattern = pattern
    objRegExp.IgnoreCase = True
    objRegExp.Global = True

    If objRegExp.test(myString) Then
        TestRegExp = myString
    End If
End Function


Public Sub GetListOfFolders()
    ' define vars for collection and array
    Dim col As New Collection
    Dim dirtree() As Variant

    ' for use with converting array to dictionary
    Dim parenttree As Object
    Set parenttree = CreateObject("Scripting.Dictionary")

    Dim newparenttree As Object
    Set newparenttree = CreateObject("Scripting.Dictionary")

    ' prepare regex stuff
    Dim objRegExp As RegExp
    Dim objMatch As Match
    Dim colMatches As MatchCollection
    Dim RetStr As String
    Dim key As String
    Dim value As String
    Dim parent As String

    ' the main Outlook stuff
    Dim Session As Outlook.NameSpace
    Dim Folders As Outlook.Folders
    Dim Folder As Outlook.Folder

    ' ge the inbox
    Set Session = Application.Session
    Set objSourceFolder = Session.GetDefaultFolder(olFolderInbox)

    ' find all folders in the inbox
    Set Folders = objSourceFolder.Folders
    For Each Folder In Folders
        col.Add (Folder.Name)
        Call ListFolders(Folder, 1, col)
    Next

    ' convert collection to array
    dirtree = toArray(col)

    'Debug.Print Join(dirtree, vbCr)

    ' begin regex matching
    Set objRegExp = New RegExp
    objRegExp.IgnoreCase = True
    objRegExp.Global = True

    ' building newparenttree with limited results
    Dim newv As String


    Dim count As Integer
    Dim line As Variant
    For Each line In dirtree
        key = ""

        objRegExp.pattern = "(§*)(.*)"
        If (objRegExp.test(line)) Then
            Set colMatches = objRegExp.Execute(line)

            count = 0
            For Each objMatch In colMatches
                If count = 0 Then
                    key = objMatch.SubMatches(0)
                    value = objMatch.SubMatches(1)
                End If
                count = 1
            Next

            parent = parenttree(key)
            FullName = parent & "\" & value
            parenttree(key & "§") = FullName

            ' trim this "12345 resolved" to this "12345"
            objRegExp.pattern = "(\d{5,})(?:\s.*|$)"
            newv = objRegExp.Replace(value, "$1")

            ' if it has already been added, set it to null. we don't want duplicate entrys to have a value
            If Not IsNumeric(newparenttree(newv)) Then
                newparenttree(newv) = ""
            Else
                newparenttree(newv) = FullName
            End If

            'Debug.Print newv & " = " & newparenttree(newv)
        End If
    Next

    ' remove § from all folders
    For i = LBound(dirtree) To UBound(dirtree)
        dirtree(i) = Replace(dirtree(i), "§", "")
    Next i

    ' for use with converting array to dictionary
    Dim casenum As String
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")

    ' only get folders that match
    For Each line In dirtree
        casenum = TestRegExp(CStr(line), "\d{5,}(\s.*|$)")
        If Not casenum = "" Then
            casenum = objRegExp.Replace(casenum, "$1")
            d(casenum) = d(casenum)   1
            'Debug.Print casenum & " = " & d(casenum)
        End If
    Next

    ' remove duplicate folders - (1, 2, 2) gives (1)
    Dim trimparenttree As Object
    Set trimparenttree = CreateObject("Scripting.Dictionary")

    Dim v As Variant
    For Each v In d.keys()
        'newv = objRegExp.Replace(v, "$1")
        If d(v) = 1 Then
            trimparenttree(v) = newparenttree(v)
            'Debug.Print v & " = " & newparenttree(v)
        End If
    Next v

    ' get emails
    Dim intCount As Integer
    Dim paceCounter As Integer
    paceCounter = 0
    objRegExp.pattern = "cas-(\d{5,})"

    'For intCount = objSourceFolder.Items.Count To 1 Step -1
    For intCount = objSourceFolder.Items.count To objSourceFolder.Items.count - 49 Step -1
        Set objVariant = objSourceFolder.Items.Item(intCount)
        DoEvents

        If objVariant.Class = olMail Then
            strSender = objVariant.SenderName

            If (objRegExp.test(objVariant.Subject)) Then
                Set colMatches = objRegExp.Execute(objVariant.Subject)

                For Each objMatch In colMatches
                    'Debug.Print Mid(objMatch, 5, objMatch.Length)
                    'Debug.Print objRegExp.Replace(objMatch, "$1")

                    ' if trimparenttree has a value, then:
                    If trimparenttree(Mid(objMatch, 5, objMatch.Length)) <> "" Then
                        ' if email has been marked as read
                        If objVariant.UnRead = False Then

                        ' don't move last unread email...

                            Debug.Print "Moving email:"
                            Debug.Print "    " & objVariant.Subject
                            Debug.Print "Into folder:"
                            Debug.Print "    " & trimparenttree(Mid(objMatch, 5, objMatch.Length))
                            Debug.Print ""
                        End If
                        ' set destination folder
                        ' move email
                    End If
                Next
            End If
        End If

        paceCounter = paceCounter   1
        If paceCounter > 50 Then
            MsgBox "You have moved " & paceCounter & " items so far." & vbCrLf & "To continue click OK or press CTRL   Break to kill script." & vbCrLf & "Resetting Throttle to 0"
            paceCounter = 0
        End If
    Next
End Sub

*edit: for those interested, i found a way to get the folder from a path here

http://stackoverflow.com/questions/17049546/get-mapi-folder-in-outlook-from-folder-path

still trying to figure out how to skip the most recent read email...