從電子郵件複製到excel

Question

我不是VBA的專家，有一個我找不出來的錯誤，請你幫忙指教一下？

我需要一個excel宏從一個文件夾中的所有電子郵件複製到我的excel，谷歌搜索，並找到下面的代碼。該代碼運行良好的一些電子郵件，之後將有一個運行時錯誤440：數組索引超出界限在這條線。

abody =斯普利特（objfolder.Items（I）。體，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 

這是未經測試，所以我離開了測試給你。 :)