Код Excel VBA работает, кроме одного компьютера - Ошибка 91

Question

У меня есть подпункт Excel VBA, который используется для поиска контактной информации в Outlook.

Эта функция работает на многих компьютерах, кроме одного, который является основным пользователем этой функции, на котором она выдает ошибку:

Error 91: Object variable or With block variable not set

Может кто-нибудь помочь мне, пожалуйста?

'Function to import Outlook contacts according to their client code
Sub ExportOutlookAddressBook()

Application.ScreenUpdating = False
    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olAL As Outlook.AddressList
    Dim olEntry As Outlook.AddressEntry
    Dim CodeClient As String
    Dim RCompanyName As String
    Dim i As Integer
    Dim AccountCount As Integer

    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    CodeClient = 0
    RCompanyName = 0
    i = 0
    AccountCount = olNS.Accounts.Count
    Range("AA6:AF10").ClearContents
    For i = 1 To AccountCount
        Set olAL = olNS.AddressLists(i) 'Change name if different contacts list name
        Set olEntry = olAL.AddressEntries(1)
        ActiveWorkbook.ActiveSheet.Range("K6").Select
        CodeClient = ActiveCell.Value
        ActiveWorkbook.ActiveSheet.Range("AA6").Select

        For Each olEntry In olAL.AddressEntries
            ' your looping code here
            RCompanyName = Left(Right(olEntry.GetContact.CompanyName, 7), 6)
            If RCompanyName = CodeClient Then
            ActiveCell.Value = olEntry.GetContact.FullName
            ActiveCell.Offset(0, 1).Value = olEntry.GetContact.BusinessTelephoneNumber 'business phone number
            ActiveCell.Offset(0, 2).Value = olEntry.Address 'email address
            ActiveCell.Offset(0, 3).Value = olEntry.GetContact.CompanyName
            ActiveCell.Offset(0, 4).Value = olEntry.GetContact.BusinessAddress
            ActiveCell.Offset(1, 0).Select
            End If
        Next olEntry
    Next i

    Set olApp = Nothing
    Set olNS = Nothing
    Set olAL = Nothing
    Application.ScreenUpdating = True
    ActiveWorkbook.ActiveSheet.Range("K7").Select
End Sub

Answer 1

Попробуй это.

Помимо добавления If Nothing..., я привел в порядок некоторые другие повторяющиеся коды.

Option Explicit  'this line is recommended at the very top of every module.


'Function to import Outlook contacts according to their client code
Sub ExportOutlookAddressBook()
    Dim olApp As Outlook.Application, olNS As Outlook.Namespace, olAL As Outlook.AddressList
    Dim olEntry As Outlook.AddressEntry, CodeClient As String, RCompanyName As String, i As Long
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Application.ScreenUpdating = False
    Range("AA6:AF10").ClearContents

    For i = 1 To olNS.Accounts.Count
        Set olAL = olNS.AddressLists(i) 'Change name if different contacts list name
        Set olEntry = olAL.AddressEntries(1)
        CodeClient = ActiveWorkbook.ActiveSheet.Range("K6")
        ActiveWorkbook.ActiveSheet.Range("AA6").Select

        For Each olEntry In olAL.AddressEntries
            ' your looping code here
            RCompanyName = Left(Right(olEntry.GetContact.CompanyName, 7), 6)
            If RCompanyName = CodeClient Then
                With ActiveCell
                    .Value = olEntry.GetContact.FullName
                    .Offset(0, 1) = olEntry.GetContact.BusinessTelephoneNumber 'business phone number
                    .Offset(0, 2) = olEntry.Address 'email address
                    If Not olEntry.GetContact Is Nothing Then
                        If Not olEntry.GetContact.CompanyName Is Nothing Then
                            .Offset(0, 3) = olEntry.GetContact.CompanyName
                        End If
                        If Not olEntry.GetContact.BusinessAddress Is Nothing Then
                            .Offset(0, 4) = olEntry.GetContact.BusinessAddress
                        End If
                    End If
                    .Offset(1, 0).Select
                End With
            End If
        Next olEntry
    Next i

    Set olApp = Nothing
    Set olNS = Nothing
    Set olAL = Nothing
    Application.ScreenUpdating = True
    ActiveWorkbook.ActiveSheet.Range("K7").Select
End Sub