sincronizzare rubrica Outlook con Excel

Question

Ho l’impellente necessità lavorativa di sincronizzare i record della rubrica contatti del mio account Exchange online di Outlook 2013, pescando i dati dalla tabella, del foglio Anagrafica, di un file Excel che uso come gestionale clienti.

A suo tempo, su indicazione del bravissimo Norman David Jones ho inserito il seguente codice VBA

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim oOutlook As Outlook.Application

    Dim oNamespace As Outlook.Namespace

    Dim oFolder As Outlook.MAPIFolder

    Dim oContactItems As Outlook.Items

    Dim oContactItem As Outlook.ContactItem

    Dim i As Long

    Dim LRow As Long, iCols As Long

    Dim sStr As String

    Const sFoglio As String = "Foglio1"                           '<<=== Modifica

    Const iRigaIntestazioni As Long = 1                           '<<=== Modifica

    Const sColonne As String = "A:J"                               '<<=== Modifica

    Set oOutlook = New Outlook.Application

    Set oNamespace = oOutlook.GetNamespace("MAPI")

    Set oFolder = oNamespace.GetDefaultFolder(10)

    Set oContactItems = oFolder.Items

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    On Error GoTo XIT

    With SH

        LRow = LastRow(SH, .Columns(sColonne))

        iCols = .Columns(sColonne).Columns.Count

        Set Rng = .Columns(sColonne).Resize(LRow - iRigaIntestazioni + 1, iCols)

    End With

    For i = 2 To Rng.Rows.Count

        With Rng

            sStr = .Cells(i, 1).Value

        End With

            If oContactItems.Find("[CompanyName]= " & sStr) Is Nothing Then

                Set oContactItem = oContactItems.Add

            Else

                Set oContactItem = oContactItems.Find("[CompanyName] = " & sStr)

            End If

            With oContactItem

                .CompanyName = SH.Cells(i, 1)

                .BusinessAddressStreet = Cells(i, 2).Value

                .BusinessAddressCity = Cells(i, 4).Value

                .Business2TelephoneNumber = SH.Cells(i, 7)

                .Email2Address = SH.Cells(i, 10)

                .Save

            End With

        Next i

    Call MsgBox( _

         Prompt:="I contatti sono stati aggiornati!", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

        Set oContactItem = Nothing

        Set oContactItems = Nothing

        Set oFolder = Nothing

        Set oNamespace = Nothing

        Set oOutlook = Nothing

        Application.ScreenUpdating = True

    End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<=========

Successivamente ho altresì applicato le seguenti modifiche:

Const sFoglio As String = "Foglio1" sostituito con: Const sFoglio As String = "Anagrafica" ovvero il foglio dal quale prelevare i dati

Const iRigaIntestazioni As Long = 1 sostituito con: Const iRigaIntestazioni As Long = 5 ovvero il numero delle righe non comprese nella tabella

Const sColonne As String = "A:J" sostituito con: Const sColonne As String = "B:P" ovvero le colonne della tabella da sincronizzare

Tuttavia lanciando la macro vengono caricati solamente 2 record, peraltro errati.

Sembrerebbe che non ci sia il giusto collegamento/mapping tra i record all’interno delle colonne della tabella di excel e la cartella “imprese” (vedi foto 2) della rubrica di Outlook 2013

Cosa devo fare per risolvere?

 

Answer 1

Caro Norman,

Innanzitutto ti ringrazio per la disponibilità.

Come mi hai suggerito ho inserito il nuovo codice ma, excel ha creato in outlook solamente 5 nuovi contatti e peraltro nella cartella “Contatti” e non nella cartella “imprese” come avrei invece voluto.

Inoltre, di questi 5 contatti creati, uno è completamente vuoto mentre gli altri 4 riportano dati di celle che nulla hanno a che vedere con i record presenti nella tabella di excel.  

Per una migliore comprensione allego le foto sia del file excel dal quale pescare i dati e sia dei 5 nuovi contatti creati nella rubrica di outlook 2013

Attendo tue info…

Ciao!!!!

Salvatore

Answer 2

Ciao Salvatore,

Prima di considerare altre possibilità, prova a sostituire il tuo codice con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim oOutlook As Outlook.Application

    Dim oNamespace As Outlook.Namespace

    Dim oFolder As Outlook.MAPIFolder

    Dim oContactItems As Outlook.Items

    Dim oContactItem As Outlook.ContactItem

    Dim i As Long

    Dim LRow As Long, iCols As Long

    Dim sStr As String

    Const sFoglio As String = "Anagrafica"            '<<=== Modifica

    Const iRigaIntestazioni As Long = 5                  '<<=== Modifica

    Const sColonne As String = "B:P"                       '<<=== Modifica

    Set oOutlook = New Outlook.Application

    Set oNamespace = oOutlook.GetNamespace("MAPI")

    Set oFolder = oNamespace.GetDefaultFolder(10)

    Set oContactItems = oFolder.Items

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

  On Error GoTo XIT

    With SH

        LRow = LastRow(SH, .Columns(sColonne))

        iCols = .Columns(sColonne).Columns.Count

        Set Rng = .Columns(sColonne). _

            Resize(LRow - iRigaIntestazioni + 1, iCols).Offset(iRigaIntestazioni)

    End With

    For i = 2 To Rng.Rows.Count

        With Rng

            sStr = .Cells(i, 1).Value

        End With

            If oContactItems.Find("[CompanyName]= " & sStr) Is Nothing Then

                Set oContactItem = oContactItems.Add

            Else

                Set oContactItem = oContactItems.Find _

                                                                    ("[CompanyName] = " & sStr)

            End If

            With oContactItem

                .CompanyName = SH.Cells(i, 1)

                .BusinessAddressStreet = Cells(i, 2).Value

                .BusinessAddressCity = Cells(i, 4).Value

                .Business2TelephoneNumber = SH.Cells(i, 7)

                .Email2Address = SH.Cells(i, 10)

                .Save

            End With

        Next i

    Call MsgBox( _

         Prompt:="I contatti sono stati aggiornati!", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

        Set oContactItem = Nothing

        Set oContactItems = Nothing

        Set oFolder = Nothing

        Set oNamespace = Nothing

        Set oOutlook = Nothing

        Application.ScreenUpdating = True

    End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<=========

===

Regards,

Norman