Visual Basic - Outlook VBA mover correo a otra carpeta

Dim i, j As Integer

Dim olapp As Outlook.Application

Dim OLNS As Outlook.NameSpace

Dim OLFolders As Outlook.Folders

Dim olMail As Outlook.MailItem

Dim olMailx As Outlook.Account

Dim formulario As Outlook.FormRegion

Dim OLFolder1 As Outlook.MAPIFolder

Dim OLFolder2 As Outlook.MAPIFolder

Dim OLFolder3 As Outlook.MAPIFolder

'Dim OLContact As Outlook.ContactItem

Dim FSO As Scripting.FileSystemObject

Dim correo As String

'SET PARAMETERS

Set FSO = CreateObject("Scripting.FileSystemObject")

Set olapp = New Outlook.Application

Set OLNS = olapp.GetNamespace("MAPI")

Set OLFolders = OLNS.Folders

h = 9

Fn = App.Path & "\Temp.txt"

For Each OLFolder1 In OLFolders

    If OLFolder1 = "2020" Then

        For i = 1 To OLFolder1.Folders.Count

            Set OLFolder2 = OLFolder1.Folders(i)

                If OLFolder2 = "XXX" Then  --> Aqui pones el nombte de la carpeta que necesitas buscar

                            For j = 1 To OLFolder2.Items.Count

                             Set olMail = OLFolder2.Items(j)

                             With olMail

                                Open Fn For Append As h

                                   msgbox .Subject

                             End With

                            Next

                End If

            Next

    End If

Next