Произошла ошибка относительно несоответствия типа

Question

Я собираю макрос VBA для Outlook и получаю «Ошибка времени выполнения» 13: несоответствие типов. У меня нет такого опыта работы с VBA, поэтому я действительно могу использовать некоторую помощь. Программа предназначена для импорта темиз входящих писем в Outlook, он работал нормально, но теперь ошибка выполнения «13» в строке «Next olItem».

Sub PullOutlookData()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim ws As Worksheet
Dim lRow As Long
Dim vItem
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")

Set ws = ThisWorkbook.Sheets("OutlookRecord") '<--- relevant worksheet name
Set olItems = olNs.Folders("faizan.farooq@ke.com.pk").Folders("Inbox").Items '<--- RELEVANT FOLDER name
rCount = 1
Sheet14.Range("A1:D2000").Clear
For Each olItem In olItems
    rCount = rCount + 1
    ws.Range("A" & rCount).value = olItem.SenderName
    ws.Range("B" & rCount).value = olItem.Subject

Next olItem
ws.UsedRange.WrapText = False

Call SliceDice
Call FlipColumns

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub
Private Sub test()
    Application.OnTime Now + TimeValue("00:01:00"), "PullOutlookData"
End Sub

Answer 1

Код немного очистился и, надеюсь, исправил вашу проблему ...

Sub PullOutlookData()
    On Error GoTo ExitSub
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .EnableEvents = False
    End With
    ActiveSheet.DisplayPageBreaks = False

    Dim olApp As Outlook.Application: Set olApp = New Outlook.Application
    Dim olNs As Outlook.Namespace: Set olNs = olApp.GetNamespace("MAPI")
    Dim Inbox As Outlook.MAPIFolder: Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Dim olItems As Outlook.Items: Set olItems = Inbox.Items

    Dim olItem As Outlook.MailItem
    Dim ws As Worksheet, vItem As Variant, i As Long, rCount As Long

    Set ws = ThisWorkbook.Sheets("OutlookRecord") '<--- relevant worksheet name

    ws.UsedRange.ClearContents
    'Sheet14.Range("A1:D2000").Clear

    rCount = 2
    For i = 1 To olItems.Count
        Set vItem = Inbox.Items.Item(i)
        DoEvents
        If vItem.Class = olMail Then
            ws.Range("A" & rCount) = vItem.SenderName
            ws.Range("B" & rCount) = vItem.Subject
            rCount = rCount + 1    
        End If
        'If i > 100 Then Exit For
    Next i

    ws.UsedRange.WrapText = False

    'Call SliceDice
    'Call FlipColumns

ExitSub:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .EnableEvents = True
    End With
    ActiveSheet.DisplayPageBreaks = True

End Sub