Код VBA, не заполняющий рабочий лист

Question

Код, указанный ниже, получен из другого сообщения SO: Excel VBA Code to retrieve e-mails from 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 

End Sub

, когда я отладки и парить в течение последних нескольких строк, кажется, код извлечения информации из Outlook, правильно. Однако извлеченные данные (тема электронной почты и т. Д.) Не заполняются на моем листе. Из того, что я могу собрать, я правильно установил переменную рабочего листа, не знаю, что происходит.

Спасибо за помощь

---

Update:

Worksheet заполняемых в настоящее время. Я пытаюсь заставить код пройти через столбец адресов электронной почты и извлечь «время, полученное» из писем, если адреса совпадают с адресами в моих папках.

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

Адрес электронной почты: адрес электронной почты вы хотите найти в подпапке или подкаталог? Код ТОЛЬКО ищет в каждой папке в папке «Входящие», он не смотрит в фактический почтовый ящик.

Попробуйте эти изменения:

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