定义excel范围的问题是将数组粘贴到outlook中

Question

我使用以下脚本从电子邮件正文中获取信息作为1D并将其放入Excel中。它运作良好但最近它已经开始在粘贴范围时抛出错误。我认为定义范围是一个简单的问题，但我不明白为什么？我已经尝试了几种方法，它总是在某个地方失败。此处的示例数据为：http://pastebin.com/mXZAWD90

代码是从outlook触发的，如果这有所不同？

Sub _to_excel()
    On Error GoTo 0
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")

     Dim ThermoMail As Outlook.MailItem
    Set ThermoMail = Application.ActiveInspector.CurrentItem

    On Error Resume Next
    Set xlObj = GetObject(, "Excel.Application")
    On Error GoTo 0
    If xlObj = Empty Then Set xlObj = CreateObject("Excel.Application")
    xlObj.Visible = True
    xlObj.Workbooks.Add


    Dim msgText, delimtedMessage, Delim1 As String
    delimtedMessage = ThermoMail.Body

'Remove everything before "Lead Source:" and after "ELMS"
TrimmedArray = Split(delimtedMessage, "Source:")
delimtedMessage = TrimmedArray(1)
TrimmedArray = Split(delimtedMessage, "ELMS")
delimtedMessage = TrimmedArray(0)

TrimmedArray = Split(delimtedMessage, "Address:")
TrimmedArray(1) = Replace(TrimmedArray(1), ",", vbCrLf)
delimtedMessage = TrimmedArray(0) & "Address:" & TrimmedArray(1)

Dim pasteRange As Range
'Split the array at each return
messageArray = Split(delimtedMessage, vbCrLf)

'PROBLEMS START HERE
'paste the split array into the worksheet
lastRow = UBound(messageArray) + 1
pasteRange = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, 1))
ActiveSheet.pasteRange = WorksheetFunction.Transpose(messageArray)
Call splitAtColons
ThermoMail.Close (olDiscard)
End Sub

Answer 1

您错过了Set语句，而pasteRange不是Activesheet的属性 - 它是一个Range变量，因此：

Set pasteRange = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, 1))
pasteRange.Value = WorksheetFunction.Transpose(messageArray)

Answer 2

@Siddharth Rout的建议就是答案。我使用Dim ws As Worksheet正确定义了活动表，然后就可以消除pasteRange的使用。我认为问题部分源于从Outlook触发代码时使用ActiveSheet的问题。

Sub Thermo_to_excel()
    On Error GoTo 0
    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")

     Dim ThermoMail As Outlook.MailItem
    Set ThermoMail = Application.ActiveInspector.CurrentItem

    On Error Resume Next
    Set xlObj = GetObject(, "Excel.Application")
    On Error GoTo 0
    If xlObj = Empty Then Set xlObj = CreateObject("Excel.Application")
    xlObj.Visible = True
    xlObj.Workbooks.Add
    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")


    Dim msgText, delimtedMessage, Delim1 As String
    delimtedMessage = ThermoMail.Body

'Remove everything before "Lead Source:" and after "ELMS"
TrimmedArray = Split(delimtedMessage, "Source:")
delimtedMessage = TrimmedArray(1)
TrimmedArray = Split(delimtedMessage, "ELMS")
delimtedMessage = TrimmedArray(0)

TrimmedArray = Split(delimtedMessage, "Address:")
TrimmedArray(1) = Replace(TrimmedArray(1), ",", vbCrLf)
delimtedMessage = TrimmedArray(0) & "Address:" & TrimmedArray(1)


'Split the array at each return
messageArray = Split(delimtedMessage, vbCrLf)

'paste the split array into the worksheet
lastRow = UBound(messageArray) + 1
ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1)).Value = WorksheetFunction.Transpose(messageArray)
Call splitAtColons
ThermoMail.Close (olDiscard)
End Sub

修改

试试这个

Sub Thermo_to_excel()
    Dim myOlApp As Object, mynamespace As Object
    Dim ThermoMail As Object
    Dim msgText, delimtedMessage, Delim1 As String

    Dim oXLApp As Object, oXLWb As Object, oXLWs As Object

    Set myOlApp = Outlook.Application
    Set mynamespace = myOlApp.GetNamespace("mapi")
    Set ThermoMail = Application.ActiveInspector.CurrentItem

    delimtedMessage = ThermoMail.Body

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    Set oXLWb = oXLApp.Workbooks.Add
    Set oXLWs = oXLWb.Sheets("Sheet1")

    'Remove everything before "Lead Source:" and after "ELMS"
    TrimmedArray = Split(delimtedMessage, "Source:")
    delimtedMessage = TrimmedArray(1)
    TrimmedArray = Split(delimtedMessage, "ELMS")
    delimtedMessage = TrimmedArray(0)

    TrimmedArray = Split(delimtedMessage, "Address:")
    TrimmedArray(1) = Replace(TrimmedArray(1), ",", vbCrLf)
    delimtedMessage = TrimmedArray(0) & "Address:" & TrimmedArray(1)

    'Split the array at each return
    messageArray = Split(delimtedMessage, vbCrLf)

    'paste the split array into the worksheet
    lastRow = UBound(messageArray) + 1

    With oXLWs
        .Range(.Cells(1, 1), .Cells(lastRow, 1)).Value = _
        oXLApp.WorksheetFunction.Transpose(messageArray)
    End With

    Call splitAtColons
    ThermoMail.Close (olDiscard)
End Sub