Question

我试图在一个单词后得到字符串，该单词会为我提供所需的数据，并将每个“-”之后的所有短语放入excel的新单元格中，除了RE：，其中我省略了“ RE：”，只保留了TS ...票证ID。

此代码通过选择Outlook中的电子邮件，然后仅对所选电子邮件运行宏来起作用。

这是具有

的主题的示例

示例主题

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

身体示例

尊敬的贸易伙伴，

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

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

交易详细信息：＃4＃附上

请更正并重新发送数据。

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

ref：_00D50c9MW._5000z1J3cG8：ref

在＃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 = "sassuport@sass.com"


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

Answer 1

您可以在VBA中使用SPLIT功能，

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

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

1 个答案: