Bonsoir à tous,
J'utilise un code excel VBA 2007 depuis 6 ans sans souci, mais depuis quelques jours il bloque quasiment dès le départ.
Fonctionnement normal du code :
Je saisi le nom d'un contact dans une cellule, ensuite le code affiche le nom et les coordonnées du contact dans différentes cellules.
Le code va chercher les informations dans les contacts d'Outlook.
Aujourd'hui il se bloque à ce niveau :
Resultat = Resultat & Cible.LastName & ","
Next
Voici le code complet :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim Recherche As String
If Not Application.Intersect(Target, Range("G30")) Is Nothing Then
If Range("G30") = "Graphic Communication" Then
Rows("33:49").EntireRow.Hidden = True
Rows("50:175").EntireRow.Hidden = False
Else
Rows("33:49").EntireRow.Hidden = False
Rows("50:175").EntireRow.Hidden = True
End If
End If
If Not Target.Address = "$D$4" Then Exit Sub
Set olApp = New Outlook.Application
Set dossierContacts = _
olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Dim s, i#, txt$
For Each Cible In dossierContacts.Items
Resultat = Resultat & Cible.LastName & ","
Next
s = Split(Resultat, ",")
1 For i = 1 To UBound(s)
txt = s(i)
If LCase(txt) < LCase(s(i - 1)) Then 'tri croissant
s(i) = s(i - 1)
s(i - 1) = txt
GoTo 1
End If
Next
Resultat = Join(s, ",")
Range("D4").Validation.Delete
Range("D4").Validation.Add xlValidateList, _
Formula1:=Resultat
Set Cible = Nothing
Set dossierContacts = Nothing
'olApp.Quit
Set olApp = Nothing
' Si le changement du nom en D4 ne c'est pas fait, on sort
If Not Target.Address = "$D$4" Then Exit Sub
On Error GoTo Fin
Application.EnableEvents = False
Recherche = Range("D4")
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Set Cible = dossierContacts.Items.Find("[LastName] = '" & Recherche & "'")
If Not Cible Is Nothing Then
Range("G1") = Cible.CompanyName
Range("G2") = Cible.FullName
Range("G3") = Cible.BusinessAddressStreet
Range("G4") = Cible.BusinessAddressPostalCode
Range("H4") = Cible.BusinessAddressCity
Range("G5") = Cible.BusinessTelephoneNumber
Sheets("Lettre").Range("F12") = Cible.Email1Address
Else
MsgBox "Aucun contact trouvé avec le nom : " & Recherche, vbInformation, "OUPS ..."
End If
Fin:
En espérant que quelqu'un veuille bien m'aider à résoudre mon problème.
D'avance je vous remercie pour votre aide.
Naitgo