Question

我有代码将电子邮件的主题从我选择的文件夹导出到Excel工作簿。我需要将主题中第一个“空格”之后的文本导出到另一列（最好是C列）。以下是几个主题行的示例：

“321-654321批准更多词语”

和

“APR＃987-123456 CONTIGENT有更多文字要遵循”

我希望在一列中主题的第一个空格之前的所有数字（或），以及在不同列中的数字，第一个空格之后的所有内容。

这是我想要输出的一个例子

A栏 - B栏 - C栏

XXX-XXXXX - DateOf电子邮件 - 事件状态

这是我正在使用的代码，我相信我在Stackoverflow上找到了这个宏。另外，我不能跳过让用户选择文件夹并把我想要这个宏的文件夹放在代码里面吗？

   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

Re：“...跳过让用户选择文件夹并放入我想要的文件夹......”

如果Source文件夹位于默认收件箱中，则

设置fld = myNamespace.GetDefaultFolder（olFolderInbox）.Folders。（“Source”）

如果Source文件夹较深，则根据需要添加尽可能多的.Folders（“...”）。

如果源文件夹不在默认收件箱中，则Get reference to additional Inbox

拆分主题行以导出到Excel中的单独列

1 个答案: