拆分主題行以導出到Excel中的單獨列中

Question

我有將從我選擇的文件夾導出到Excel工作簿的電子郵件主題的代碼。我需要將主題中第一個「空格」之後的文本導出到另一列（最好是C列）。下面是一對夫婦的主題行是什麼樣子的例子：

" 321-654321 APPROVED With more words to follow "

和

" APR#987-123456 CONTIGENT With More text to follow "

我想有數量（或）在主題的第一空間之前，一切都在一列，數字之後的所有內容，第一個空格，在不同的列中。

這裏是我想有

Column A - Column B - Column C

XXX-XXXXX - DateOf Email - Status of the incident

這是我目前使用的代碼輸出的一個例子，我相信我發現了＃2這個宏。此外，我不能跳過讓用戶選擇文件夾，並把我想要這個宏在代碼內的行爲的文件夾？

Sub ExportToExcel() 

    On Error GoTo ErrHandler 

    Dim appExcel As Excel.Application 
    Dim wkb As Excel.Workbook 
    Dim wks As Excel.Worksheet 
    Dim rng As Excel.Range 
    Dim strSheet As String 
    Dim strPath As String 
    Dim intRowCounter As Integer 
    Dim intColumnCounter As Integer 
    Dim msg As Outlook.MailItem 
    Dim nms As Outlook.Namespace 
    Dim fld As Outlook.MAPIFolder 
    Dim itm As Object 

    strSheet = "spreadhsheet.xlsx" 
    strPath = "C:\MyOutlookMacro\" 
    strSheet = strPath & strSheet 

    Debug.Print strSheet 
    'Select export folder 
    Set nms = Application.GetNamespace("MAPI") 
    Set fld = nms.PickFolder 
    'Handle potential errors with Select Folder dialog box. 
    If fld Is Nothing Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    ElseIf fld.DefaultItemType <> olMailItem Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    ElseIf fld.Items.Count = 0 Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    End If 
    'Open and activate Excel workbook. 
    Set appExcel = CreateObject("Excel.Application") 
    appExcel.Workbooks.Open (strSheet) 
    Set wkb = appExcel.ActiveWorkbook 
    Set wks = wkb.Sheets(1) 
    wks.Activate 
    appExcel.Application.Visible = True 
    'Copy field items in mail folder. 
    For Each itm In fld.Items 
     intColumnCounter = 1 
     Set msg = itm 
     intRowCounter = intRowCounter + 3 
     intColumnCounter = intColumnCounter + 1 
     Set rng = wks.Cells(intRowCounter, intColumnCounter) 
     rng.Value = msg.Subject 
     intColumnCounter = intColumnCounter + 1 
     Set rng = wks.Cells(intRowCounter, intColumnCounter) 
     rng.Value = msg.SentOn 
    Next itm 

    Set appExcel = Nothing 
    Set wkb = Nothing 
    Set wks = Nothing 
    Set rng = Nothing 
    Set msg = Nothing 
    Set nms = Nothing 
    Set fld = Nothing 
    Set itm = Nothing 
    Exit Sub 

    ErrHandler: If Err.Number = 1004 Then 
     MsgBox strSheet & " doesn't exist", vbOKOnly, "Error" 
    Else 
     MsgBox Err.Number & "; Description: ", vbOKOnly, "Error" 
    End If 

    Set appExcel = Nothing 
    Set wkb = Nothing 
    Set wks = Nothing 
    Set rng = Nothing 
    Set msg = Nothing 
    Set nms = Nothing 
    Set fld = Nothing 
    Set itm = Nothing 
    End Sub 

------------------------------- 



Sub ExportToExcel() 

    On Error GoTo ErrHandler 

    Dim appExcel As Excel.Application 
    Dim wkb As Excel.Workbook 
    Dim wks As Excel.Worksheet 
    Dim rng As Excel.Range 
    Dim strSheet As String 
    Dim strPath As String 
    Dim intRowCounter As Integer 
    Dim intColumnCounter As Integer 
    Dim msg As Outlook.MailItem 
    Dim nms As Outlook.NameSpace 
    Dim fld As Outlook.MAPIFolder 
    Dim itm As Object 
    Dim Words As String 

    strSheet = "spreadhsheet.xlsx" 
    strPath = "C:\MyOutlookMacro\" 
    strSheet = strPath & strSheet 

    Debug.Print strSheet 
    'Select export folder 
    Set nms = Application.GetNamespace("MAPI") 
    Set fld = nms.PickFolder 
    'Set fld = Set fld = myNamespace.GetDefaultFolder(olFolderInbox).Folders("SpreadsheetItems") 

    'Handle potential errors with Select Folder dialog box. 
    If fld Is Nothing Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    ElseIf fld.DefaultItemType <> olMailItem Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    ElseIf fld.Items.Count = 0 Then 
     MsgBox "There are no mail messages to export", vbOKOnly, "Error" 
     Exit Sub 
    End If 


    'Open and activate Excel workbook. 
    Set appExcel = CreateObject("Excel.Application") 
    appExcel.Workbooks.Open (strSheet) 
    Set wkb = appExcel.ActiveWorkbook 
    Set wks = wkb.Sheets(1) 
    wks.Activate 
    appExcel.Application.Visible = True 


    'Copy field items in mail folder. 


For Each itm In fld.Items 
    intColumnCounter = 1 
    Set msg = itm 

    Words = Split(msg.Subject, " ") 

    intRowCounter = intRowCounter + 3 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = Words(0) 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = msg.SentOn 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = Words(2) 

Next itm 

    Set appExcel = Nothing 
    Set wkb = Nothing 
    Set wks = Nothing 
    Set rng = Nothing 
    Set msg = Nothing 
    Set nms = Nothing 
    Set fld = Nothing 
    Set itm = Nothing 
    Exit Sub 

ErrHandler:  If Err.Number = 1004 Then 
     MsgBox strSheet & " doesn't exist", vbOKOnly, "Error" 
    Else 
     MsgBox Err.Number & "; Description: ", vbOKOnly, "Error" 
    End If 

    Set appExcel = Nothing 
    Set wkb = Nothing 
    Set wks = Nothing 
    Set rng = Nothing 
    Set msg = Nothing 
    Set nms = Nothing 
    Set fld = Nothing 
    Set itm = Nothing 
    End Sub 

**我收到「編譯錯誤：預期數組@ rng.Value =單詞（0）**

Answer 1

回覆：拆分主題

採用分體式

Dim Words() As String ' not Dim Words as String 

For Each itm In fld.Items 
    intColumnCounter = 1 
    Set msg = itm 

    Words = Split(msg.Subject, " ") 

    intRowCounter = intRowCounter + 3 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = Words(0) 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = msg.SentOn 

    intColumnCounter = intColumnCounter + 1 
    Set rng = wks.Cells(intRowCounter, intColumnCounter) 
    rng.Value = Words(2) 

Next itm 

回覆：「...跳過讓用戶選擇文件夾，並把我想要什麼文件夾...」

如果源文件夾是我n中的默認收件箱，然後

設置FLD = myNamespace.GetDefaultFolder（olFolderInbox）.Folders。（ 「源」）

添加儘可能多的.Folders（ 「...」）作爲必要的，如果源文件夾是更深。

如果源文件夾不是默認收件箱中，然後Get reference to additional Inbox