Vba 将outlook主题行分隔为列

我有下面的代码，我正试图修改它，将主题行拆分为六列，以便在Excel中查看

Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"

For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body

xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject


Next
End Sub

我的数据格式如下

SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)

下面是我打算离开的7个专栏

寄件人 位置 高球 日期 班次结束时间 轮班休假时间 休假类型

在它的当前状态下，你可以看到它只生成两列，我不知道如何将主题行分开

任何帮助都将不胜感激

谢谢使用拆分

Sub subject2excel()

Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object

Dim Words() As String

'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")

xlobj.Visible = True
xlobj.Workbooks.Add

'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"

For i = 1 To myFolder.Items.count

    Set myitem = myFolder.Items(i)

    If TypeOf myitem Is MailItem Then
        'msgText = myitem.body

        xlobj.Range("a" & i + 1).Value = myitem.Sender
        'xlobj.Range("b" & i + 1).Value = myitem.Subject

        Words = Split(myitem.Subject, " | ")

        For j = 0 To UBound(Words)
            Debug.Print Words(j)
        Next j

    End If

Next i

exitRoutine:
    Set myOlApp = Nothing
    Set myFolder = Nothing
    Set xlobj = Nothing
    Set myitem = Nothing

End Sub

---

我能够解决这个问题

Sub subject2excel() 

Dim olFolder As Outlook.Folder 
Dim olItem As Outlook.MailItem 
Dim olNS As Outlook.NameSpace 
Dim xlApp As Object 
Dim xlWB As Object 
Dim i As Long 
Dim j As Long 
Dim vSubject As Variant 


On Error Resume Next 
Set xlApp = GetObject(, "Excel.Application") 
If Err <> 0 Then 
    Set xlApp = CreateObject("Excel.Application") 
End If 
On Error GoTo 0 'err_Handler
xlApp.Visible = True 
Set xlWB = xlApp.Workbooks.Add 
 'Set Heading
With xlWB.Sheets(1) 
    .Range("A" & 1).Value = "Sender" 
    .Range("B" & 1).Value = "Location" 
    .Range("C" & 1).Value = "LOB" 
    .Range("D" & 1).Value = "Date" 
    .Range("E" & 1).Value = "Shift End Time" 
    .Range("F" & 1).Value = "Requested Leave Time" 
    .Range("G" & 1).Value = "Paid/Unpaid" 
End With 
 'Fill sheet
Set olNS = GetNamespace("MAPI") 
Set olFolder = olNS.PickFolder 
For i = 1 To olFolder.Items.Count 
    Set olItem = olFolder.Items(i) 
    If InStr(1, olItem.Subject, "|") > 0 Then 
        vSubject = Split(olItem.Subject, "|") 
        With xlWB.Sheets(1) 
            .Range("A" & i + 1).Value = olItem.Sender 
            .Range("B" & i + 1).Value = vSubject(0) 
            .Range("C" & i + 1).Value = vSubject(1) 
            .Range("D" & i + 1).Value = vSubject(2) 
            .Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1)) 
            .Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1)) 
            .Range("F" & i + 1).HorizontalAlignment = -4152 'align right
            .Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "") 
        End With 
    End If 
Next i 
xlWB.Sheets(1).UsedRange.Columns.Autofit 
exitRoutine: 
Set olFolder = Nothing 
Set xlApp = Nothing 
Set xlWB = Nothing 
Set olItem = Nothing 
lbl_Exit: 
Exit Sub 
err_Handler: 
GoTo lbl_Exit 
End Sub

子主题2Excel（）
将文件夹设置为Outlook.Folder
将我设置为Outlook.MailItem
将olNS设置为Outlook.NameSpace
将xlApp作为对象
作为对象的Dim xlWB
我想我会坚持多久
Dim j尽可能长
Dim vSubject作为变体
出错时继续下一步
Set xlApp=GetObject（，“Excel.Application”）
如果错误为0，则
设置xlApp=CreateObject（“Excel.Application”）
如果结束
错误转到0时出现错误\u处理程序
xlApp.Visible=True
设置xlWB=xlApp.Workbooks.Add
“设定航向
带xlWB.表（1）
.Range（“A”和1）.Value=“发件人”
.Range（“B”和1）.Value=“位置”
.Range（“C”和1）.Value=“LOB”
.Range（“D”和1）。Value=“日期”
.Range（“E”和1）.Value=“班次结束时间”
.Range（“F”和1）.Value=“请求的休假时间”
.Range（“G”和1）.Value=“已支付/未支付”
以
“填写表格
设置olNS=GetNamespace（“MAPI”）
设置olFolder=olNS.PickFolder
对于i=1到olFolder.Items.Count
Set-olItem=olFolder.Items（i）
如果InStr（1，m.Subject，“|”）大于0，则
vSubject=拆分（m.Subject，“|”）
带xlWB.表（1）
.Range（“A”&i+1）.Value=m.Sender
.Range（“B”&i+1）。值=vSubject（0）
.Range（“C”&i+1）。值=vSubject（1）
.Range（“D”&i+1）。值=vSubject（2）
.范围（“E”和i+1）.值=修剪（中间（V主体（3）、仪表（1、V主体（3）、Chr（58））+1））
.范围（“F”和i+1）.值=修剪（中间（V主体（4）、仪表（1、V主体（4）、Chr（58））+1））
.范围（“F”&i+1）.水平对齐=-4152'右对齐
.范围（“G”和i+1）.值=替换（修剪（中间（V主体（5）、仪表板（V主体（5）、Chr（40））+1））、Chr（41），“”）
以
如果结束
接下来我
xlWB.Sheets（1）.UsedRange.Columns.Autofit
现存的：
设置olFolder=Nothing
设置xlApp=Nothing
设置xlWB=Nothing
设置m=无
lbl_出口：
出口接头
错误处理程序：
转到lbl_出口
端接头

谢谢你的回复，尼顿，但是当我尝试代码时，我得到的唯一结果是发件人的信息。在主题下什么都没有。