如何将电子邮件移动到文件夹内的文件夹？

Question

我正在尝试移动与现有模式匹配的电子邮件。

如何将邮件移至文件夹内的文件夹？例如designteam>麦克或designteam>桑迪

我复制了此内容。我很难理解Tabs在做什么。它只是存储选项卡的数量吗？

在这一点上，我可以存储文件夹的路径吗？

Public Sub GetListOfFolders()
    On Error GoTo On_Error

    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim Folders As Outlook.Folders
    Dim Folder As Outlook.Folder
    Dim reply As Integer

    Set Session = Application.Session

    Set Folders = Session.Folders

    For Each Folder In Folders
        Call RecurseFolders(Folder, vbTab, Report)
    Next
    Dim retValue As Boolean
    Debug.Print (Report)

Exiting:
        Set Session = Nothing
        Exit Sub
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting

End Sub


Private Sub RecurseFolders(CurrentFolder As Outlook.Folder, Tabs, Report As String)
    Dim Table As Outlook.Table
    Dim Row As Outlook.Row
    Dim rowValues() As Variant
    Dim SubFolders As Outlook.Folders
    Dim SubFolder As Outlook.Folder

    Report = Report & Tabs & CurrentFolder.Name & vbCrLf

    Set SubFolders = CurrentFolder.Folders
    For Each SubFolder In SubFolders
        Call RecurseFolders(SubFolder, Tabs & vbTab, Report)
    Next SubFolder

End Sub

Answer 1

假设您知道文件夹的位置，则无需搜索它们。

在收件箱正下方的designteam文件夹中。进行适当的调整。

Option Explicit

Sub moveToSubfolder()

Dim olInbox As Folder
Dim desTeamFolder As Folder
Dim mikeFolder As Folder
Dim sandyFolder As Folder

Dim currItem As Object

Set olInbox = Session.GetDefaultFolder(olFolderInbox)

Set desTeamFolder = olInbox.Folders("designteam")

With desTeamFolder
    Set mikeFolder = .Folders("mike")
    Set sandyFolder = .Folders("sandy")
End With

Set currItem = ActiveInspector.CurrentItem

If currItem.Class = olMail Then
    If InStr(currItem.Subject, "mike pattern") Then
        currItem.Move mikeFolder
    ElseIf InStr(currItem.Subject, "sandy pattern") Then
        currItem.Move sandyFolder
    Else
        Debug.Print "no match"
    End If
End If

End Sub

Answer 2

我的总答案超出了堆栈溢出的30,000个字符的限制，因此我将其分为两部分。这部分包括所有说明性文字和一些代码。第二部分包括其余代码。第一部分中间的斜体注释显示了第二部分所属的位置。

下面的代码是正在进行的工作，而不是完善的解决方案，但是其中包含一些可能立即有用的宏，我相信它包含您自己的解决方案所需的所有代码片段。

在确定需要重新排列Outlook存储和文件夹时，我领先于您。看到您的问题时，我已经到达确定问题规模的阶段。我添加了一个宏，可以移动选定的电子邮件。这显示了如何查找源文件夹和目标文件夹以及如何将电子邮件从一个移动到另一个。该例程对我来说不是非常有用，因为我有太多电子邮件，但其中没有一个保存在正确的文件夹中，但可以确保我认为您需要的所有内容都在这里。

此代码是为Excel工作簿设计的。我知道我想将数据存储在工作表中，因此我需要同时使用Excel和Outlook VBA。 Outlook可以将数据推送到Excel或Excel从Outlook中提取数据。自从我确信自己只需要一些Excel宏之后，我就大吃一惊了，而且我希望将单个问题的所有代码都放在一个地方。

您将需要创建一个启用宏的工作簿。该工作簿必须包含一个名为“电子邮件”的工作表，并且必须引用“ Microsoft Outlook n.nn对象库”，其中“ n.nn”取决于所使用的Outlook版本。

您将需要在该工作簿中创建一个用户表单。如果您不熟悉用户表单，请搜索“ vba create userform”，您会发现许多教程。我的用户表单仅使用标签控件，并且其中没有代码，因此非常容易。

我使用此用户表单报告进度。在我的系统（包含13,000封电子邮件）上，我的一些宏需要花费几分钟。我讨厌说“这可能需要几分钟到几个小时”的程序，然后安静下来直到完成。我想知道程序正在做某事。我的用户表单如下：

不用担心文本匹配；它可以帮助对齐标签。表单顶部有一个标签，然后是四个标签的两行。我给标签涂了颜色，所以您可以看到它们的尺寸。您必须匹配我的名字：

Form:        frmProgress
First row:   lblMsg
Second row:  lblFldrName  lblFldrCrnt  lblFldrOf  lblFldrMax
Third row:   lblItemName  lblItemCrnt  lblItemOf  lblItemMax

在我的表单上，lblFldrName，lblFldrCrnt，lblItemName和lblItemCrnt中的文本是右对齐的。我相信这可以改善外观，但这并不重要。

我将Excel的PERSONAL.XLSB用作子程序和函数库。有些例程仅适用于Excel，某些例程适用于任何版本的VBA，而某些例程适用于其他Office产品，例如Outlook。以下功能来自我命名为“ LibOutlook”的模块：

Option Explicit
Public Function GetFldrRef(ByRef AppOut As Outlook.Application, _
                           ByVal FldrName As String, _
                           ByVal Create As Boolean, ByRef ErrMsg As String, _
                           Optional ByVal Sep As String = "\") As Outlook.Folder

  ' Returns reference to the Outlook folder named FldrName
  ' Returns Nothing if:
  '    the store cannot be found
  '    the folder cannot be found and Create is False

  ' AppOut    Open copy of Outlook
  ' FldrName  The full name of the folder in the format:
  '             StoreName\Folder1\Folder2\...
  ' Create    If True, the folder will be created if it does not exist.
  '           Note, the store must exist. This routine can create a folder
  '           within a store but it cannot create a store.
  ' ErrMsg    The reason for any failure
  ' Sep       If the separator for FldrName is not "\", used to specify the
  '           actual separator.

  Dim FldrChld As Outlook.Folder
  Dim FldrCrnt As Outlook.Folder
  Dim FldrNameCrnt As String
  Dim FldrNameParts() As String
  Dim InxP As Long
  Dim NoError As Boolean

  If FldrName = "" Then
    ErrMsg = "No folder name provided"
    Set GetFldrRef = Nothing
  End If

  FldrNameParts = Split(FldrName, Sep)

  Set FldrCrnt = Nothing
  On Error Resume Next
  Set FldrCrnt = AppOut.Session.Folders(FldrNameParts(0))
  On Error GoTo 0
  If FldrCrnt Is Nothing Then
    ' Store name not recognised
    Debug.Print FldrNameParts(0) & " is not recognised as a store"
    Debug.Assert False     ' Fatal error
    Set GetFldrRef = Nothing
    Exit Function
  End If
  FldrNameCrnt = FldrNameParts(0)

  NoError = True
  For InxP = 1 To UBound(FldrNameParts)
  Set FldrChld = Nothing
    On Error Resume Next
    Set FldrChld = FldrCrnt.Folders(FldrNameParts(InxP))
    On Error GoTo 0
    If FldrChld Is Nothing Then
      If Not Create Then
        ' Sub-folder name not recognised but folder FldrName must exist
        ErrMsg = """" & FldrNameParts(InxP) & """ is not recognised as a " & _
                 "folder within " & FldrNameCrnt
        Debug.Assert False    ' Fatal error
        Set GetFldrRef = Nothing
        Exit Function
      Else
        NoError = False
        Exit For
      End If
    End If
    Set FldrCrnt = FldrChld
    FldrNameCrnt = FldrNameCrnt & Sep & FldrNameParts(InxP)
    Set FldrChld = Nothing
  Next

  If NoError Then
    ' Entire FldrName successfully converted to folder reference
    ErrMsg = ""
    Set GetFldrRef = FldrCrnt
    Exit Function
  End If

  ' FldrCrnt is a existing folder within Outlook named FldrNameCrnt
  ' Subfolder FldrNameParts(InxP) does not exist within FldrCrnt
  ' Create Subfolder FldrNameParts(InxP) and any children

  For InxP = InxP To UBound(FldrNameParts)
    On Error Resume Next
    Set FldrChld = FldrCrnt.Folders.Add(FldrNameParts(InxP))
    On Error GoTo 0
    If FldrChld Is Nothing Then
      ' Attempt to create sub-folder failed
      ErrMsg = """" & FldrNameParts(InxP) & """ cannot be created as a " & _
               "sub-folder within folder " & FldrNameCrnt
      Debug.Assert False    ' Fatal error
      Set GetFldrRef = Nothing
      Exit Function
    End If
    Set FldrCrnt = FldrChld
    FldrNameCrnt = FldrNameCrnt & Sep & FldrNameParts(InxP)
    Set FldrChld = Nothing
  Next

  Set GetFldrRef = FldrCrnt

End Function

您可以在工作簿中的单独模块或与其他代码相同的模块中的PERSONAL.XLSB中包含以上功能。

以下代码属于您的工作簿中的一个模块：

代码已移至第二个答案，因为超出了大小限制。

您会注意到，我大量使用Debug.Print来帮助调试代码。由于我已经完全调试了部分代码，因此其中一些Debug.Print已被注释掉。其他Debug.Print仍处于活动状态，因为我仍在编写代码。我也倾向于通过代码将Debug.Assert False植入每个分支的顶部。这将在第一次执行分支时停止执行。一旦检查了分支的执行情况，就将其注释掉。活跃的Debug.Assert False告诉我我尚未测试分支。

您将需要修改功能GetOtherParty。如果您是收件人，则对方是发送方，如果您是发件人，则对方是收件人。我有两个电子邮件地址。此例程检查我是发送方还是接收方，并获取对方的名称。您将必须修改此电子邮件地址。

第一个宏是TidyPhase1。这将搜索Outlook安装中每个商店的每个文件夹，并在工作表“电子邮件”中为每一封电子邮件写一行。它创建“状态”，“另一方”，“文件夹”，“计数”和“接收时间”列。稍后我将解释“状态”和“计数”。如果另一方是“ SmithJohn@gmail.com”，并且文件夹在“ abc \ def \ ghi”中，则您已向约翰·史密斯发送了一封电子邮件或从其中接收了一封电子邮件，该电子邮件位于文件夹“ abc \ def \ ghi”中。最初，我有一列指示是否发送或接收电子邮件。我发现这对下一个宏很麻烦，其价值并不明显。我包括了收到的时间，因此，如果我不理解一行，可以在Outlook中找到该电子邮件。如果您决定为其他属性添加一列，请使用与我一样的常量作为列号，并根据需要更新常量ColEmailsSortLast。

请注意，TidyPhase1不使用递归。递归是一种非常方便的技术，但速度很慢。尽管不是LIFO堆栈，但我使用Collection来构建自己的堆栈。如有必要，我将进一步解释。

下一个宏是TidyPhase2。这将合并同一方和文件夹的行。 “计数”列标识合并行的源行数。在此宏的末尾，工作表“电子邮件”将由另一方进行排序，并将包含以下行：

Status   Other party          Folder  Count  Received
         SmithJohn@gmail.com  FolderA     2
         SmithJohn@gmail.com  FolderB    10
         SmithJohn@gmail.com  FolderC     1  12/8/2019 20:13  

FolderC中只有一封给John的电子邮件，因此接收到的日期/时间以您的本地格式显示。我发现有个约会对调查放错位置的电子邮件很有用。如果FolderB是正确的文件夹，请在“状态”列中键入值以提供：

Status   Other party          Folder  Count  Received
move     SmithJohn@gmail.com  FolderA     2
dest     SmithJohn@gmail.com  FolderB    10
move     SmithJohn@gmail.com  FolderC     1  12/8/2019 20:13  

宏HandleDestAndMove会将John的电子邮件从FolderA和FolderC移到FolderB。宏完成后，工作表将如下所示：

Status   Other party          Folder  Count  Received
dest     SmithJohn@gmail.com  FolderB    13

如果正确的文件夹是FolderD，则添加一行以给出：

Status   Other party          Folder  Count  Received
move     SmithJohn@gmail.com  FolderA     2
move     SmithJohn@gmail.com  FolderB    10
move     SmithJohn@gmail.com  FolderC     1  12/8/2019 20:13
dest     SmithJohn@gmail.com  FolderD

宏完成后，工作表将如下所示：

Status   Other party          Folder  Count  Received
dest     SmithJohn@gmail.com  FolderD    13

我已经看到了改善宏的方法，但是现在决定给您一些东西，而不是等到我对其进行了改进之后，因为这些改进对您可能并不重要。

总结：

• 宏TidyPhase1显示了如何在每个商店的每个文件夹中搜索电子邮件。

• 宏HandleDestAndMove显示了如何将文件夹名称转换为文件夹引用，以及如何将电子邮件从一个文件夹移动到另一个文件夹。

如果有问题，请回来。

Answer 3

由于大小限制，代码从第一个答案移出了

Option Explicit

  ' Requires reference to "Microsoft Outlook n.nn Object Library" where "n.nn"
  ' depends on the version of Outlook used.

  Const ColEmailsSortFirst As Long = 1
  Const ColEmailsStatus As Long = 1
  Const ColEmailsOtherParty As Long = 2
  Const ColEmailsFldrName As Long = 3
  Const ColEmailsCount As Long = 4
  Const ColEmailsReceivedTime As Long = 5
  Const ColEmailsSortLast As Long = 5
Sub TidyPhase1()

  ' * Accesses Outlook and copies other party, folder and received time
  '   of every email to worksheet "Emails".
  ' * If the sender email address is not one of my addresses, it is
  '   used to identify the other party.  Otherwise the macro uses Recipients
  '   to build the other party.

  Dim AppOut As Outlook.Application
  Dim EmailAddressOtherParty As String
  Dim FldrsToCheck As Collection
  Dim FldrCrnt As Outlook.Folder
  Dim FldrNameCrnt As String
  Dim InxA As Long
  Dim InxF As Long
  Dim InxI As Long
  'Dim InxR As Long
  Dim InxS As Long
  Dim RowEmailsCrnt As Long
  Dim WshtEmails As Worksheet

  Load frmProgress
  With frmProgress
    .Caption = "Tidy Outlook Phase 1"
    .lblMsg.Caption = "Opening Outlook if not already open"
    .lblFldr.Caption = ""
    .lblFldrCrnt.Caption = ""
    .lblFldrOf.Caption = ""
    .lblFldrMax.Caption = ""
    .lblItem.Caption = ""
    .lblItemCrnt.Caption = ""
    .lblItemOf.Caption = ""
    .lblItemMax.Caption = ""
    .Show vbModeless
  End With
  DoEvents

  Application.ScreenUpdating = False
  Set WshtEmails = Worksheets("Emails")
  With WshtEmails
    .Cells.EntireRow.Delete
    WshtEmails.Cells(1, ColEmailsStatus).Value = "Status"
    WshtEmails.Cells(1, ColEmailsOtherParty).Value = "Other party"
    WshtEmails.Cells(1, ColEmailsFldrName).Value = "Folder"
    WshtEmails.Cells(1, ColEmailsCount).Value = "Count"
    WshtEmails.Cells(1, ColEmailsReceivedTime).Value = "Received"
  End With

  Set AppOut = CreateObject("Outlook.Application")

  With frmProgress
    .lblMsg.Caption = "Preparing to search Outlook folders for emails"
    .lblFldr.Caption = "Folders to check"
    .lblFldrMax.Caption = "0"
  End With
  DoEvents

  Set FldrsToCheck = New Collection

  With AppOut
    With .Session
      ' Initialise FldrsToCheck with reference to and name of
      ' every accessible store
      For InxS = 1 To .Folders.Count
        FldrsToCheck.Add VBA.Array(.Folders(InxS), .Folders(InxS).Name)
        With frmProgress
          .lblFldrMax.Caption = FldrsToCheck.Count
        End With
        DoEvents
      Next
    End With
  End With

  ' Process all folders
  With frmProgress
    .lblMsg.Caption = "Checking folders"
    .lblFldr.Caption = "Folders to check"
    .lblFldrMax.Caption = FldrsToCheck.Count
  End With
  DoEvents
  RowEmailsCrnt = 2
  Do While FldrsToCheck.Count > 0
    ' Extract next folder to process and delete it
    Set FldrCrnt = FldrsToCheck(1)(0)
    FldrNameCrnt = FldrsToCheck(1)(1)
    Call FldrsToCheck.Remove(1)
    'Debug.Print FldrCrnt.Name & " " & FldrNameCrnt & " " & FldrCrnt.Items.Count
    With FldrCrnt
      If .Folders.Count > 0 Then
        ' Folder contains sub-folders
        ' Add sub-folders to FldrsToCheck
        For InxF = 1 To .Folders.Count
          FldrsToCheck.Add VBA.Array(.Folders(InxF), _
                                     FldrNameCrnt & "\" & .Folders(InxF).Name)
          With frmProgress
           .lblFldrMax.Caption = FldrsToCheck.Count
          End With
          DoEvents
        Next
      End If
      If .Items.Count > 0 Then
        ' Folder contains items
        If .DefaultItemType = olMailItem Then
          ' Folder could contains MailItems
          With frmProgress
           .lblItem.Caption = "Item within current folder"
           .lblItemCrnt.Caption = "0"
           .lblItemOf.Caption = "of"
           .lblItemMax.Caption = FldrCrnt.Items.Count
          End With
          DoEvents
          ' Output details of all mail items to worksheet "Emails"
          For InxI = 1 To .Items.Count
            With .Items(InxI)
              If .Class = olMail Then
                WshtEmails.Cells(RowEmailsCrnt, ColEmailsOtherParty).Value = _
                                                    GetOtherParty(FldrCrnt.Items(InxI))
                WshtEmails.Cells(RowEmailsCrnt, ColEmailsFldrName).Value = FldrNameCrnt
                WshtEmails.Cells(RowEmailsCrnt, ColEmailsCount).Value = 1
                WshtEmails.Cells(RowEmailsCrnt, ColEmailsReceivedTime).Value = .ReceivedTime
                RowEmailsCrnt = RowEmailsCrnt + 1
              End If
            End With
            With frmProgress
             .lblItemCrnt.Caption = InxI
            End With
          Next InxI
        End If  ' .DefaultItemType = olMailItem
      End If  ' .Items.Count > 0
    End With  ' FldrCrnt
    With frmProgress
      .lblFldrMax.Caption = FldrsToCheck.Count
      .lblItem.Caption = ""
      .lblItemCrnt.Caption = ""
      .lblItemOf.Caption = ""
      .lblItemMax.Caption = ""
    End With
    DoEvents
  Loop

  With frmProgress
    .lblMsg.Caption = "Closing Outlook if not opened by another process"
  End With
  DoEvents

  AppOut.Quit

  Set AppOut = Nothing
  Unload frmProgress

  With WshtEmails
    .Columns.AutoFit
    .Rows.AutoFit
    .Cells.VerticalAlignment = xlTop
  End With

  Application.ScreenUpdating = True

End Sub
Sub TidyPhase2()

  ' 1. Sorts worksheet "Emails" by Other party.
  ' 2. Rows for the same Other party and Folder are combined.

  Dim RngSortAll As Range
  Dim RngSortCol As Range
  Dim RowEmailsCrnt As Long
  Dim RowEmailsLast As Long
  Dim WshtEmails As Worksheet

  Load frmProgress
  With frmProgress
    .Caption = "Tidy Outlook Phase 2"
    .lblMsg.Caption = "Sorting worksheet by 'Other Party'"
    .lblFldr.Caption = ""
    .lblFldrCrnt.Caption = ""
    .lblFldrOf.Caption = ""
    .lblFldrMax.Caption = ""
    .lblItem.Caption = ""
    .lblItemCrnt.Caption = ""
    .lblItemOf.Caption = ""
    .lblItemMax.Caption = ""
    .Show vbModeless
  End With
  DoEvents

  Application.ScreenUpdating = False

  Set WshtEmails = Worksheets("Emails")

  With WshtEmails

    RowEmailsLast = .Cells(Rows.Count, ColEmailsCount).End(xlUp).Row
    Set RngSortAll = .Range(.Cells(1, ColEmailsSortFirst), _
                            .Cells(RowEmailsLast, ColEmailsSortLast))
    Set RngSortCol = .Range(.Cells(2, ColEmailsOtherParty), _
                            .Cells(RowEmailsLast, ColEmailsOtherParty))

    With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=RngSortCol, SortOn:=xlSortOnValues, _
                      Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange RngSortAll
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With

  End With  ' WshtEmails

  With frmProgress
    .Caption = "Tidy Outlook Phase 2"
    .lblMsg.Caption = "Merging rows for same 'Other Party' and 'Folder'"
    .lblItemCrnt.Caption = "0"
    .lblItemOf.Caption = "of"
    .lblItemMax.Caption = RowEmailsLast
  End With
  DoEvents

  With Worksheets("Emails")
    RowEmailsCrnt = 2

    Do While RowEmailsCrnt <= RowEmailsLast
      If (.Cells(RowEmailsCrnt, ColEmailsOtherParty).Value = _
          .Cells(RowEmailsCrnt - 1, ColEmailsOtherParty).Value) And _
         (.Cells(RowEmailsCrnt, ColEmailsFldrName).Value = _
          .Cells(RowEmailsCrnt - 1, ColEmailsFldrName).Value) Then
        .Cells(RowEmailsCrnt - 1, ColEmailsCount).Value = _
                      .Cells(RowEmailsCrnt - 1, ColEmailsCount).Value + _
                      .Cells(RowEmailsCrnt, ColEmailsCount).Value
        .Cells(RowEmailsCrnt - 1, ColEmailsReceivedTime).Value = ""
        .Rows(RowEmailsCrnt).Delete
        RowEmailsLast = RowEmailsLast - 1
        frmProgress.lblItemMax.Caption = RowEmailsLast
      Else
        RowEmailsCrnt = RowEmailsCrnt + 1
        frmProgress.lblItemCrnt.Caption = RowEmailsCrnt
      End If
      DoEvents
    Loop

  End With

  Unload frmProgress

  Application.ScreenUpdating = True

End Sub
Function GetOtherParty(ItemCrnt As Outlook.MailItem) As String

  ' If the sender is one of my email addresses, return recipient.
  ' Otherwise return sender.

  Dim InxR As Long
  Dim OtherParty As String
  Dim EmailIn As Boolean

  With ItemCrnt

    EmailIn = True  ' Assume incoming email until find otherwise
    OtherParty = .SenderEmailAddress
    If OtherParty = " tonydallimore@myisp.com" Then
      EmailIn = False
    ElseIf OtherParty = "tonydallimore@gmail.com" Then
      EmailIn = False
    End If

    If Not EmailIn Then
      ' Create OtherParty from Recipients
      OtherParty = .Recipients(1).Address
        For InxR = 2 To .Recipients.Count
          OtherParty = OtherParty & vbLf & .Recipients(InxR).Address
        Next
     End If

   End With

  GetOtherParty = OtherParty

End Function
Sub HandleDestAndMove()

  ' Before calling this routine:
  '  1. Find one or more rows with Other Party = "Xxxx" and with Folder not
  '     correct for Other Party Xxxx.  Set Status of these rows to "Move".
  '  2. Find the row with Other Party = "Xxxx" and with Folder correct
  '     for Other Party Xxxx.  Set Status of this row to "Dest".
  '  3. If no suitable dest row exists, because no emails for the Other Party
  '     are present in the dest folder, create such a row.  If this folder
  '     does not exist within Outlook, this routine will create it.

  ' Finds matching Dest and Move rows in worksheet "Email" and move emails
  ' from the folders identified in Move rows to the folder identified in the
  ' matching Dest row.

  ' 1. Look for "Dest" in column Status.  Record Other Party And Folder.
  ' 2. Find or create dest folder within Outlook.
  ' 3. Find a row with "Move" in column Status and the same Other Party
  '    as the dest row.
  ' 4. Find the move folder within Outlook.
  ' 5  Move all emails for the Other Party from the move folder to the
  '    dest folder.
  ' 6  Reduce count of move row and increase count of dest row
  ' 7  Repeat steps 3 to 6 until all move rows for the Other Party have
  '    been priocessed.
  ' 8  Repeat steps 1 to 7 until all dest row have been processed.
  ' 9  Delete all move rows with count of 0

  Dim AppOut As Outlook.Application
  Dim CountDest As Long
  Dim ErrMsg As String
  Dim FldrDest As Outlook.Folder
  Dim FldrDestName As String
  Dim FldrSrc As Outlook.Folder
  Dim FldrSrcName As String
  Dim InxI As Long
  Dim InxR As Long
  'Dim MatchFound As Boolean
  Dim NumFldrsDestPrcd As Long       ' Number of destination folders processed so far
  Dim NumFldrsDestTtl As Long        ' Total number of destination folders
  Dim NumItemsToMoveCrnt As Long     ' Number of emails in current move fldr according to worksheet
  Dim NumItemsToMovePrcd As Long     ' Actual number of emails moved
  Dim NumItemsToMoveTtl As Long      ' Total number of emails to move according to worksheet
  Dim OtherPartyDest As String
  Dim OtherPartyEmail As String
  Dim Rng As Range
  Dim RowEmailsCrnt As Long
  Dim RowEmailsDestOrig As Long
  Dim RowEmailsDestCrnt As Long
  Dim RowEmailsMoveOrig As Long
  Dim RowEmailsMoveCrnt As Long
  Dim WshtEmails As Worksheet

  Application.ScreenUpdating = False

  Load frmProgress
  With frmProgress
    .Caption = "Handle moves"
    .lblMsg.Caption = "Accessing work load"
    .lblFldr.Caption = "Destination folders"
    .lblFldrCrnt.Caption = ""
    .lblFldrOf.Caption = ""
    .lblFldrMax.Caption = "0"
    .lblItem.Caption = "Total mail items to move"
    .lblItemCrnt.Caption = ""
    .lblItemOf.Caption = ""
    .lblItemMax.Caption = "0"
    .Show vbModeless
  End With
  DoEvents

  Set WshtEmails = Worksheets("Emails")

  NumFldrsDestTtl = 0
  NumItemsToMoveTtl = 0

  RowEmailsCrnt = 1

  'Count number of occurrences of "dest" and "move" in status column
  With WshtEmails
    ' Find first value in status column
    Set Rng = .Columns(ColEmailsStatus).Find( _
                What:="*", After:=.Cells(RowEmailsCrnt, ColEmailsStatus), _
                LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If Rng Is Nothing Then
      Debug.Assert False
      Call MsgBox("No rows found with anything in status column", vbOKOnly)
      Unload frmProgress
      Exit Sub
    End If
    ' Process value just found in status column then find next value.
    ' Loop until next value is on row 1.
    Do While True
      If LCase(.Cells(Rng.Row, ColEmailsStatus).Value) = "dest" Then
        NumFldrsDestTtl = NumFldrsDestTtl + 1
        frmProgress.lblFldrMax.Caption = NumFldrsDestTtl
      ElseIf LCase(.Cells(Rng.Row, ColEmailsStatus).Value) = "move" Then
        If IsNumeric(.Cells(Rng.Row, ColEmailsCount).Value) Then
          NumItemsToMoveTtl = NumItemsToMoveTtl + .Cells(Rng.Row, ColEmailsCount).Value
          frmProgress.lblItemMax.Caption = NumItemsToMoveTtl
        Else
          .Cells(Rng.Row, ColEmailsCount).Value = 0
        End If
      End If
      DoEvents
      Set Rng = .Columns(ColEmailsStatus).FindNext(Rng)
      If Rng.Row = 1 Then
        ' Have looped back to top row
        Exit Do
      End If
    Loop
  End With  ' WshtEmails

  If NumFldrsDestTtl = 0 Or NumItemsToMoveTtl = 0 Then
    Debug.Assert False
    Call MsgBox("Nothing found to do", vbOKOnly)
    Unload frmProgress
    Exit Sub
   End If

  With frmProgress
    .lblMsg.Caption = "Opening Outlook if not already open"
  End With
  DoEvents

  ' There can only be one instance of Outlook open.  If Outlook is already
  ' open, CreateObject will create a link to that instance. If the user opens
  ' and closes Outlook while this macro is running, it will close the instance
  ' this macro is using.
  Set AppOut = CreateObject("Outlook.Application")

  With frmProgress
    .lblMsg.Caption = "Moving emails to correct folder"
    .lblFldrCrnt.Caption = "0"
    .lblFldrOf.Caption = "of"
    .lblItemCrnt.Caption = "0"
    .lblItemOf.Caption = "of"
  End With
  DoEvents

  RowEmailsDestOrig = 0   ' No dest row found
  RowEmailsDestCrnt = 1   ' Start row for first search for dest row

  ' This outer loop find first occurence of "dest" in status column. When
  ' inner loop has finished processing move rows, the next dest row is found.
  ' This continues until the first dest row is found again.
  Do While True

    With WshtEmails

      Set Rng = .Columns(ColEmailsStatus).Find( _
                  What:="dest", After:=.Cells(RowEmailsDestCrnt, ColEmailsStatus), _
                  LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                  SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
      If Rng Is Nothing Then
        Debug.Assert False
        Call MsgBox("No row found with 'Dest' in status column", vbOKOnly)
        Exit Sub
      End If
      If RowEmailsDestOrig = 0 Then
        ' This is first dest row found.  When it is found again, all dest rows
        ' have been processed.
        'Debug.Assert False
        RowEmailsDestOrig = Rng.Row
      ElseIf RowEmailsDestOrig = Rng.Row Then
        ' Have looped back to first dest row
        'Debug.Assert False
        Exit Do
      End If
      RowEmailsDestCrnt = Rng.Row
      OtherPartyDest = .Cells(RowEmailsDestCrnt, ColEmailsOtherParty).Value
      FldrDestName = .Cells(RowEmailsDestCrnt, ColEmailsFldrName).Value
      If .Cells(RowEmailsDestCrnt, ColEmailsCount).Value = "" Then
        'Debug.Assert False
        .Cells(RowEmailsDestCrnt, ColEmailsCount).Value = 0
      End If
      CountDest = .Cells(RowEmailsDestCrnt, ColEmailsCount).Value
      ' Count column will be increased for each email moves into dest fldr.
    End With  ' WshtEmails

    Debug.Print "Dest " & OtherPartyDest & " " & RowEmailsDestCrnt
    Debug.Print "  " & FldrDestName
    Debug.Print "  CountDest " & CountDest
    Set FldrDest = GetFldrRef(AppOut, FldrDestName, True, ErrMsg)
    If ErrMsg <> "" Then
      Debug.Print "  GetFldrRef: " & ErrMsg
    Else
      Debug.Print "  GetFldrRef: " & FldrDest.Name
    End If

    RowEmailsMoveOrig = 0                   ' No move row found
    RowEmailsMoveCrnt = RowEmailsDestCrnt   ' Start row for search for move row

    ' This inner loop find first occurence of "move" in status column after the
    ' dest row. When processing of the move row has finished, the next move row
    ' is found. This continues until the first move row is found again.
    Do While True

      With WshtEmails

        Set Rng = .Columns(ColEmailsStatus).Find( _
                    What:="move", After:=.Cells(RowEmailsMoveCrnt, ColEmailsStatus), _
                    LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Rng Is Nothing Then
          'Debug.Assert False
          Call MsgBox("No rows found with 'Move' in status column", vbOKOnly)
          Exit Do
        End If
      End With

      RowEmailsMoveCrnt = Rng.Row
      If RowEmailsMoveOrig = 0 Then
        ' This is first move row found after dest row.  When it is found again,
        ' all move rows have been checked.
        'Debug.Assert False
        RowEmailsMoveOrig = RowEmailsMoveCrnt
      ElseIf RowEmailsMoveOrig = RowEmailsMoveCrnt Then
        ' Have looped back to first move row
        'Debug.Assert False
        Exit Do
      End If

      ' Have a new move row but may not be for dest row

      If OtherPartyDest = WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsOtherParty).Value Then
        ' Have move row for current dest row
        'Debug.Assert False
        FldrSrcName = WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsFldrName).Value
        NumItemsToMoveCrnt = WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsCount).Value
        Debug.Print "  Move " & RowEmailsMoveCrnt & " " & FldrSrcName

        Set FldrSrc = GetFldrRef(AppOut, FldrSrcName, False, ErrMsg)
        If ErrMsg <> "" Then
          Debug.Print "    GetFldrRef: " & ErrMsg
          Debug.Assert False
        Else
          Debug.Print "    FldrSrc.Name: " & FldrSrc.Name
        End If

        ' Have found move row for current dest row
        ' Move all MailItems for other party to dest fldr
        For InxI = FldrSrc.Items.Count To 1 Step -1
          If OtherPartyDest = GetOtherParty(FldrSrc.Items(InxI)) Then
            Debug.Print "    Match " & FldrSrc.Items(InxI).ReceivedTime
            FldrSrc.Items(InxI).Move FldrDest
            NumItemsToMovePrcd = NumItemsToMovePrcd + 1
            CountDest = CountDest + 1
            With frmProgress
              .lblItemCrnt.Caption = NumItemsToMovePrcd
            End With
            DoEvents
            NumItemsToMoveCrnt = NumItemsToMoveCrnt - 1
          Else
            'Debug.Print "NonMt " & FldrSrc.Items(InxI).ReceivedTime
          End If
        Next InxI
        Debug.Print "    CountDest " & CountDest
        WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsCount).Value = NumItemsToMoveCrnt
        WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsReceivedTime).Value = ""
        WshtEmails.Cells(RowEmailsDestCrnt, ColEmailsCount).Value = CountDest
        Debug.Print "    NumItemsToMoveCrnt " & NumItemsToMoveCrnt
        If NumItemsToMoveCrnt <> 0 Then
          'Debug.Assert False
          ' The actual number of emails found did not match the count in the worksheet
          ' Adjust display counts
          NumItemsToMoveTtl = NumItemsToMoveTtl - NumItemsToMoveCrnt
          With frmProgress
            .lblItemMax.Caption = NumItemsToMoveTtl
          End With
          DoEvents
        End If

      End If  ' move row for current dest row

    Loop  ' for all move rows

    NumFldrsDestPrcd = NumFldrsDestPrcd + 1
    Debug.Print "NumFldrsDestPrcd " & NumFldrsDestPrcd
    With frmProgress
      .lblFldrCrnt.Caption = NumFldrsDestPrcd
    End With
    DoEvents

  Loop  ' for all dest rows

  With frmProgress
    .lblMsg.Caption = "Closing Outlook if not opened by another process"
  End With
  DoEvents

  AppOut.Quit
  Set AppOut = Nothing

  With frmProgress
    .lblMsg.Caption = "Deleting move rows with a count of zero"
    .lblFldr.Caption = ""
    .lblFldrCrnt.Caption = ""
    .lblFldrOf.Caption = ""
    .lblFldrMax.Caption = ""
    .lblItem.Caption = "Move rows deleted"
    .lblItemCrnt.Caption = "0"
    .lblItemOf.Caption = ""
    .lblItemMax.Caption = ""
  End With
  DoEvents

  With WshtEmails

    RowEmailsMoveCrnt = 1

    Do While True  ' Loop until no move rows with a count of 0

      Set Rng = .Columns(ColEmailsStatus).Find( _
                  What:="move", After:=.Cells(RowEmailsMoveCrnt, ColEmailsStatus), _
                  LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                  SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

      If Rng Is Nothing Then
        'Debug.Assert False
        ' All move row deleted
        Exit Do
      End If

      RowEmailsMoveCrnt = Rng.Row
      RowEmailsMoveOrig = RowEmailsMoveCrnt

      Do While True
        If WshtEmails.Cells(RowEmailsMoveCrnt, ColEmailsCount).Value = 0 Then
          ' This row is to be deleted
          .Rows(RowEmailsMoveCrnt).Delete
          RowEmailsMoveCrnt = RowEmailsMoveCrnt - 1
          RowEmailsMoveOrig = 0
          Exit Do
        End If
        Set Rng = .Columns(ColEmailsStatus).Find(Rng)
        RowEmailsMoveCrnt = Rng.Row
        If RowEmailsMoveOrig = RowEmailsMoveCrnt Then
          ' Have move rows but none with a count of 0
          Exit Do
        End If
      Loop  ' until row deleted or no row to delete

      If RowEmailsMoveOrig = RowEmailsMoveCrnt Then
        ' There are move rows but none with a count of 0
        Exit Do
      End If

    Loop  ' until no move rows with a count of 0

  End With

  Unload frmProgress

  Application.ScreenUpdating = True

End Sub