从主题中提取特定字符串格式以进行排序

Question

我需要从主题电子邮件中获取数据并使用它来创建/排序电子邮件。

数据以8开头，有6个字符。有时它的前面是标题“BU＃”，“BU”等。一旦我得到一个案例，我可以复制它用于其他场景。

现在我使用手动宏将项目排序到文件夹中并输入BU。我想从主题中提取数据，以便我可以突出显示一组电子邮件并运行宏，因此将它们分类到BU文件夹中。

这就是我为手动排序所做的工作。

Sub MoveToFiled()
    On Error Resume Next

    Dim ns As Outlook.NameSpace
    Dim moveToFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    Dim Myvalue As String
    Dim myFolder As Outlook.folder
    Dim myNewFolder As Outlook.folder
    Set ns = Application.GetNamespace("MAPI")

    Myvalue = InputBox("Enter BU", "Input")

    'Define path to the target folder
    Set myFolder = ns.Folders("Current Projects").Folders("BU")
    Set myNewFolder = myFolder.Folders.Add(Myvalue)
    Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
    Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)

    If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox ("No item selected")
        Exit Sub
    End If

    If moveToFolder Is Nothing Then
        MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If

    For Each objItem In Application.ActiveExplorer.Selection
        If moveToFolder.DefaultItemType = olMailItem Then
            If objItem.Class = olMail Then
                objItem.UnRead = False
                objItem.FlagStatus = olNoFlag
                objItem.Move moveToFolder
                objItem.Categories = ""
                objItem.Save
            End If
        End If
    Next    

    Set objItem = Nothing
    Set moveToFolder = Nothing
    Set ns = Nothing
    Set myFolder = Nothing
End Sub

---

每个帮助这是我想出的一个递归函数，它从主题中抓取BU，创建文件夹，移动东西 -

Sub MoveToFiledAUTO()
On Error Resume Next

Dim ns As Outlook.NameSpace
Dim moveToFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim Myvalue As String
Dim myFolder As Outlook.folder
Dim myNewFolder As Outlook.folder
Set ns = Application.GetNamespace("MAPI")
Dim vSplit As Variant
Dim sWord As Variant
Dim minisplit As Variant
Dim objSelection As Outlook.Selection

Set Conversations = ActiveExplorer.Selection.GetSelection(Outlook.OlSelectionContents.olConversationHeaders)
Set myFolder = ns.Folders("Current Projects").Folders("BU")

If Application.ActiveExplorer.Selection.Count = 0 Then
   MsgBox ("No item selected")
   Exit Sub
End If


Set objSelection = Outlook.Application.ActiveExplorer.Selection

For Each objItem In objSelection
    If TypeOf objItem Is MailItem Then
     subby = objItem.subject
        vSplit = Split(subby)
       For Each sWord In vSplit
                 If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
                     Myvalue = Left$(sWord, 6)
                     Exit For
                 ElseIf Left$(sWord, 2) = "#8" And Len(sWord) = 7 Then
                    Myvalue = Mid$(sWord, 2, 6)
                    Exit For
                 ElseIf Left$(sWord, 4) = "BU#8" And Len(sWord) = 9 Then
                     Myvalue = Mid$(sWord, 4, 6)
                     Exit For
                 ElseIf Left$(sWord, 3) = "U#8" And Len(sWord) = 8 Then
                     Myvalue = Mid$(sWord, 3, 6)
                     Exit For
                 ElseIf Left$(sWord, 3) = "BU8" And Len(sWord) = 8 Then
                     Myvalue = Mid$(sWord, 3, 6)
                     Exit For
                 ElseIf Left$(sWord, 1) = "8" And Len(sWord) = 7 Then
                     Myvalue = Left$(sWord, 6)
                     Exit For
                 Else
                 End If
         Next
    Set myNewFolder = myFolder.Folders.Add(Myvalue)
    Set moveToFolder = ns.Folders("Current Projects").Folders("BU").Folders(Myvalue)
   If moveToFolder Is Nothing Then
      MsgBox "Target folder not found!", vbOKOnly + vbExclamation, "Move Macro Error"
    End If
   If moveToFolder.DefaultItemType = olMailItem Then
      If objItem.Class = olMail Then
         objItem.UnRead = False
         objItem.FlagStatus = olNoFlag
         objItem.Move moveToFolder
         objItem.Categories = ""
         objItem.Save
      End If
  End If
    End If
Next



Set objItem = Nothing
Set moveToFolder = Nothing
Set ns = Nothing
Set myFolder = Nothing
End Sub

这将从邮件主题中提取BU，创建文件夹，并将邮件归档。谢谢！

Answer 1

这应该让你开始：

Public Function GetBUNumber(sSubject As String) As String
  Dim vSplit As Variant
  Dim sWord As Variant

  vSplit = Split(sSubject, " ")
  For Each sWord In vSplit
    If IsNumeric(sWord) Then
      If Left$(sWord, 1) = "8" And Len(sWord) = 6 Then
        GetBUNumber = sWord
        Exit Function
      End If
    End If
  Next
  GetBUNumber = "Not Found"

End Function

然后，您可以使用Myvalue调用该函数，如下所示：

Dim sFound as String
sFound = GetBUNumber(Myvalue)

它将返回以8开头或“未找到”的6位数字。

编辑：看起来你需要更多指令

在代码中更改此行：

Myvalue = InputBox("Enter BU", "Input")

对此

Myvalue = GetBUNumber(InputBox("Enter BU", "Input"))
If Myvalue = "Not Found" Then
  MsgBox "BU Number not found."
  Exit Sub
End If