Question

我不是VBA的专家，得到了一个我无法弄清楚的错误，你能帮忙建议吗？

我需要一个excel宏从文件夹中的所有电子邮件复制到我的Excel，用Google搜索并找到以下代码。对于某些电子邮件，代码运行正常，之后会出现运行时错误440：此行的数组索引超出界限。

abody = Split（objfolder.Items（i）.Body，vbNewLine）

大多数时候我只是记录宏并从那里进行编辑所以我真的不明白什么是数组索引超出范围。真的希望你能开导我，非常感谢你提前帮助... =）完整代码可以在下面找到...

在宏将获取其正在处理的电子邮件的详细信息的部分中添加...但令我感到困惑的是收到的电子邮件的详细信息与正文不符。有人可以请帮忙提供建议吗？

Sub test()

Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant

Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")

Cnt = 0
For Each olMail In olFldr.Items
On Error GoTo errorhandler
Cnt = Cnt + 1

abody = Split(olFldr.Items(Cnt).Body, vbNewLine)

For j = 0 To UBound(abody)
Sheet1.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next

ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
Cells(1, 1).Value = arrData(1, Cnt)

Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"

olFldr.Items(Cnt).Move olNS.GetDefaultFolder(6).Folders("Processed")

Next

Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing

errorhandler:
Application.CutCopyMode = False
Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing
Exit Sub

End Sub

更新代码：

Sub test()

Dim olApp As Object
Dim olNS As Object
Dim olFldr As Object
Dim olMail As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim Cnt As Long
Dim arrData() As Variant
Dim ws As Worksheet

Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFldr = olNS.GetDefaultFolder(olFolderInbox).Folders("temp")
Set ws = ThisWorkbook.Sheets("Sheet1")

EmailCount = olFldr.Items.Count

MsgBox "Number of emails in the folder: " & EmailCount, , "email count"

Cnt = 1
For Each olMail In olFldr.Items

abody = Split(olMail.Body, vbNewLine)

For j = 0 To UBound(abody)
ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
Next

ReDim Preserve arrData(1 To 1, 1 To Cnt)
arrData(1, Cnt) = olMail.ReceivedTime
ws.Cells(1, 1).Value = arrData(1, Cnt)

ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"

olMail.Move olNS.GetDefaultFolder(6).Folders("Processed")

Cnt = Cnt + 1


Next

Set olApp = Nothing
Set olNS = Nothing
Set olFldr = Nothing

End Sub

Answer 1

您可以尝试将循环部分更改为此。
还要为目标工作表添加声明和变量赋值。

Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") 'added this to avoid the subscript out of range

Cnt = 1
For Each olMail In olFldr.Items
On Error GoTo errorhandler

    abody = Split(olMail.Body, vbNewLine) 'changed this to olMail.Body since you are already iterating each mail
    For j = 0 To UBound(abody)
    ws.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j) 'use the declared ws here
    Next

    ReDim Preserve arrData(1 To 1, 1 To Cnt)
    arrData(1, Cnt) = olMail.ReceivedTime
    ws.Cells(1, 1).Value = arrData(1, Cnt) 'use ws here as well if same Sheet1
    ws.Cells(1, 1).NumberFormat = "dd/mm/yyyy hh:mm:ss AM/PM"
    olMail.Move olNS.GetDefaultFolder(6).Folders("Processed") 'change to olMail as well
    Cnt = Cnt + 1
Next

未经测试，所以我将测试留给您。：）

从电子邮件复制到Excel

1 个答案: