将 Outlook 主题行分成几列

Question

我尝试修改以下代码，将主题行分成六列，以便在 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 个栏目。

发件人地点高球日期班次结束时间轮班休假时间请假类型

如您所见，在当前状态下它只生成两列，我不知道如何将主题行分开。

任何帮助将不胜感激。

谢谢

Answer 1

使用拆分。

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

Answer 2

我能够解决问题

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

将 Outlook 主题行分成几列

separting outlook subject line into columns

outlook

vba