VBA代码不填充工作表

下面的代码来源于另一个SOpost： Excel VBA代码来从Outlook中检索电子邮件 。

目的是从Outlook电子邮件中查找信息并将其放入Excel中。

Sub test2() Dim olApp As Outlook.Application Dim olNs As Outlook.Namespace Dim olFolder As Outlook.MAPIFolder Dim olMail As Outlook.MailItem Dim eFolder As Outlook.Folder Dim i As Long Dim x As Date Dim wb As Workbook Dim ws As Worksheet Dim iCounter As Long Dim lrow As Long Set wb = ActiveWorkbook Set ws = wb.Worksheets("Sheet1") wb.Activate ws.Select Set olApp = New Outlook.Application Set olNs = olApp.GetNamespace("MAPI") x = Date For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name) For i = olFolder.Items.Count To 1 Step -1 If TypeOf olFolder.Items(i) Is MailItem Then Set olMail = olFolder.Items(i) For iCounter = 2 To lrow If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then With ws lrow = .Range("A" & .Rows.Count).End(xlUp).Row .Range("A" & lrow).Offset(1, 0).Value = olMail.Subject .Range("A" & lrow).Offset(1, 1).Value = olMail.ReceivedTime .Range("A" & lrow).Offset(1, 2).Value = olMail.SenderEmailAddress End With End If Next iCounter End If Next i Set olFolder = Nothing Next eFolder 

结束小组

当我debugging并将鼠标hover在最后几行时，代码似乎正确地从Outlook中提取信息。 但是，提取的数据（电子邮件的主题等）没有填充在我的工作表中。 从我可以收集到的东西，我已经正确设置了工作表variables，不知道发生了什么事情。

感谢所有的帮助

---

更新：

工作performance在正在填充。 我试图让代码遍历一列电子邮件地址，如果地址与我的文件夹中的地址匹配，从电子邮件中提取“收到的时间”。

Answer 1

做了一些改变。 看看这是否有效。

 Dim olApp As Outlook.Application Dim olNs As Outlook.Namespace Dim olFolder As Outlook.MAPIFolder Dim olMail As Outlook.MailItem Dim eFolder As Outlook.folder Dim i As Long Dim x As Date Dim wb As Workbook Dim ws As Worksheet Dim iCounter As Long Dim lrow As Long Set wb = ActiveWorkbook Set ws = wb.WorkSheets("Sheet1") Set olApp = New Outlook.Application Set olNs = olApp.GetNamespace("MAPI") x = Date 'i think you want column E here, not L? lastRow = ThisWorkbook.WorkSheets("Sheet1").Cells(Rows.Count, "L").End(xlUp).Row For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.name) For i = olFolder.Items.Count To 1 Step -1 For iCounter = 2 To lastRow If TypeOf olFolder.Items(i) Is MailItem Then Set olMail = olFolder.Items(i) If InStr(olMail.SenderEmailAddress, ws.Cells(iCounter, 5).Value) > 0 Then 'qualify the cell With ws lrow = .Range("A" & .Rows.Count).End(xlUp).Row .Range("A" & lrow + 1).Value = olMail.SUBJECT .Range("B" & lrow + 1).Value = olMail.ReceivedTime .Range("C" & lrow + 1).Value = olMail.SenderEmailAddress End With End If Next iCounter End If Next i Set olFolder = Nothing 

Answer 2

您正在收件箱或子文件夹中查找电子邮件吗？ 代码仅在收件箱中的每个FOLDER中查找，而不是在实际的收件箱中查看。

尝试这些更改：

 Dim i As Long, j As Long 'Add "j as long" 'For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders For j = 0 To olNs.GetDefaultFolder(olFolderInbox).Folders.Count ' loop through the folders, starting at 0 (which we'll call the inbox) If j = 0 Then Set olFolder = olNs.GetDefaultFolder(olFolderInbox) Else Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(j) End If ...rest of loop Next ' Remove 'efolder' from here