excel - 如何在 Outlook 电子邮件的主题中的每个“-”之后在 Excel 中分隔到一个新单元格

Question

我试图在一个单词之后获取字符串，该单词为我提供所需的数据和每个“-”之后的所有短语到 excel 中的一个新单元格中，但在 RE: 中，我省略了“RE:”并且只留下 TS .. . 票号。

此代码通过在 Outlook 中选择电子邮件，然后仅为所选电子邮件运行宏来工作。

这是一个具有以下主题的示例

示例主题

---

RE：TS001889493 - 翻译失败 - 入站 - （VEXP/HONCE/文档类型 214 - 地图 AVE_NMHG_I_214_4010_XML_SAT - N103 中的错误条件关系错误（0066）[参考：_00D50c9MW._5000z1J3cG8：参考]

---

身体示例

尊敬的贸易伙伴，

我们从发件人 ID：VEXP/收件人 ID：HONCE 收到了附加的 214 笔交易，由于 N1_03 (0066) 中的条件关系错误而失败。

根据映射逻辑，如果存在 N103 或 N104，则需要另一个，因为它们之间存在条件关系。但在收到的输入文件中，N104 值丢失，因此出现错误。

交易详情：#4# 附件

请更正并重新发送数据。

谢谢你，西蒙·哈格斯 | Sass 支持 - 基本

参考：_00D50c9MW._5000z1J3cG8：参考

---

#num# 中发生的情况是，它在匹配“TS”票证 ID 后得到所有这些的总和。

这是我到目前为止的代码

Option Explicit
Sub WritingTicketNumberAndfailuresnew()
 Dim xlApp As Object
 Dim xlWB As Object
 Dim xlSheet As Object
 Dim rCount, STicket, SticketNumber As Long
 Dim bXStarted As Boolean
 Dim enviro As String
 Dim strPath, SSubject As String

 Dim currentExplorer As Explorer
 Dim Selection As Selection
 Dim olItem As Outlook.MailItem
 Dim obj As Object
 Dim strColS, strColB, sassupport, sMailDateReceived, SFrom As String


 Dim Actions1, Actions2, Actions3, Actions4 As Boolean
 Dim I, cnt, email_needed As Integer

' Get Excel set up
     On Error Resume Next
     Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
         Application.StatusBar = "Please wait while Excel source is opened ... "
         Set xlApp = CreateObject("Excel.Application")
         bXStarted = True
     End If
     On Error GoTo 0

'Open a specific workbook to input the data the path of the workbook under the windows user account

     enviro = CStr(Environ("USERPROFILE"))
     strPath = enviro & "\Documents\topthreeticket.xlsx"
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")


' Add column names
  xlSheet.Range("A1") = "Email Subject"
  xlSheet.Range("B1") = "Map Name"
  xlSheet.Range("C1") = "Case Number"
  xlSheet.Range("D1") = "No. Of Failures"
  xlSheet.Range("E1") = "Date"
  xlSheet.Range("F1") = "Week Number"


sassupport = "[e-mail]"


On Error Resume Next
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(-4162).Row
'needed for Exchange 2016. Remove if causing blank lines.
rCount = rCount + 1

' get the values from outlook
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
    For Each obj In Selection
    Set olItem = obj

'collect the fields for ticket number and failure count
    strColS = olItem.Subject
    strColB = olItem.Body
    SFrom = olItem.SenderEmailAddress
    sMailDateReceived = olItem.ReceivedTime

Dim sFailures, stmp1, stmp2, stmp3 As String
Dim RegX As Object, Mats As Object
Dim Found As Boolean

' Check the number of failures from body
   sFailures = "0"

   stmp1 = strColB
   Set RegX = CreateObject("VBScript.RegExp")
   With RegX
       .Global = True
       .Pattern = "#\d+#"
       Set Mats = .Execute(stmp1)
   End With
   If (RegX.Test(stmp1)) Then
       stmp2 = Mats(0)
       Found = True
       stmp3 = Mid(stmp2, 2, Len(stmp2) - 2)
       sFailures = stmp3
    Else
       With RegX
          .Pattern = "#d\d+"
          Set Mats = .Execute(stmp1)
       End With
       If (RegX.Test(stmp1)) Then
           stmp2 = Mats(0)
           Found = True
           stmp3 = Mid(stmp2, 2, Len(stmp2) - 1)
           sFailures = stmp3
        End If
    End If

    Set Mats = Nothing
    Set RegX = Nothing

Dim tmp As String
Dim RegX2 As Object, Mats1 As Object

tmp = strColS
Set RegX2 = CreateObject("VBScript.RegExp")
With RegX2
    .Global = True
    .Pattern = "TS00\d{7}"
    Set Mats1 = .Execute(tmp)
End With
If (RegX2.Test(tmp)) Then
   Set Mats1 = RegX2.Execute(tmp)
   tmp = Mats1(0)
Else
    With RegX2
      .Pattern = "T.S\d{9}"
      Set Mats1 = .Execute(tmp)
    End With
    If (RegX.Test(tmp)) Then
        tmp = Mats1(0)
    End If
End If
Set Mats1 = Nothing
Set RegX2 = Nothing



Dim tempticketnum, tmpdate As String
Dim ticketnumposition As Integer
'write them in the excel sheet
If SFrom = sassupport Then
    xlSheet.Range("A" & rCount) = strColS
    xlSheet.Range("B" & rCount) = tmp2
    xlSheet.Range("C" & rCount) = tmp
    xlSheet.Range("D" & rCount) = sFailures ' number of failures
    xlSheet.Range("E" & rCount) = sMailDateReceived
    rCount = rCount + 1
End If
Next

     Set olItem = Nothing
     Set obj = Nothing
     Set currentExplorer = Nothing
     Set xlSheet = Nothing
     Set xlWB = Nothing
     Set xlApp = Nothing

End Sub

标签： excelvbaoutlook

Answer 1

您可以SPLIT在 VBA 中使用该函数，就像这样

Sub x()

Dim s As String
Dim a() As String

s = "this-will-test-this-out"

a = Split(s, "-")

Range("a1").Resize(UBound(a) + 1, 1).Value = Application.Transpose(a)

End Sub