probleme d'optimisation d'une macro

[ylabarre]

Bonjour,

j'ai une macro qui en entré prend un fichier csv contenant une liste de contact et une macro qui permet à l'aide de ce fichier insérer les contacts du fichiers non présent dans Outlook et si ils existent les mettres a jour.

voici ma macro :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Public Sub ImportContacts()
    ' This code allow to import all contacts contain in a csv file
    ' Created by Yannick Labarre 2007-06-26
 
    ' Déclaration des variables
    Dim appExcel As Excel.Application ' Application Excel
    Dim wbExcel As Excel.Workbook ' Classeur Excel
    Dim wsExcel As Excel.Worksheet ' Feuille Excel
 
    Dim i As Integer
    Dim LastRow As Integer
    Dim myOlApp As Object
    Dim myItem As Object
    Dim contContact As Outlook.ContactItem
    Dim dirLocation As String
    Dim Racine As String
 
    Dim business_address_street As String
    Dim business_telephone_number As String
    Dim business_fax_number As String
    Dim mobile_telephone_number As String
    Dim description As String
    Dim contact_found As String
 
    Racine = "C:\Temp\" & Environ("username") & "\"
    dirLocation = Racine & Environ("username") & "_contacts.csv"
 
    'creer un item de type contact qu'on initialisera avec les donnees du fichier csv
    Set myOlApp = CreateObject("Outlook.Application")
 
    ' Ouverture de l'application
    Set appExcel = CreateObject("Excel.Application")
    ' Ouverture d'un fichier Excel
    Set wbExcel = appExcel.Workbooks.Open(dirLocation)
    ' wsExcel correspond à la première feuille du fichier
    Set wsExcel = wbExcel.Worksheets(1)
 
    LastRow = wsExcel.ListObjects.Application.ActiveCell.SpecialCells(xlCellTypeLastCell).Row
 
    ' Select the default folder which contains all the contacts
    Set nms = Application.GetNamespace("MAPI")
    Set fld = nms.GetDefaultFolder(olFolderContacts)
    ' Get the number of contacts
    lng = fld.Items.Count
 
    ' on parcourt tout les contacts du fichier
    For i = 1 To LastRow
       contact_found = 0
       ' Get the number of contacts
       lngCount = lng
       'MsgBox "lngCount : " & lngCount & " - lng" & lng
       Do While lngCount <> 0
           Set contContact = fld.Items.Item(lngCount)
 
           ' if the contact exist update him
           If (StrComp(contContact.EntryID, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 15), vbTextCompare) = 0) Or ((StrComp(contContact.UserProperties.Add("outlookid", olText, True, 1), wsExcel.ListObjects.Application.ActiveCell.Cells(i, 15), vbTextCompare) = 0) And (StrComp(contContact.UserProperties.Add("sugarid", olText, True, 1), wsExcel.ListObjects.Application.ActiveCell.Cells(i, 16), vbTextCompare) = 0)) Then
 
		If StrComp(contContact.title, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 1), vbTextCompare) <> 0 Then
                    contContact.title = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 1)
                End If
                If StrComp(contContact.FirstName, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 2), vbTextCompare) <> 0 Then
                    contContact.FirstName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 2)
                End If
                If StrComp(contContact.LastName, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 3), vbTextCompare) <> 0 Then
                    contContact.LastName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 3)
                End If
                If StrComp(contContact.JobTitle, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 4), vbTextCompare) <> 0 Then
                    contContact.JobTitle = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 4)
                End If
                If StrComp(contContact.CompanyName, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 5), vbTextCompare) <> 0 Then
                    contContact.CompanyName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 5)
                End If
                If StrComp(contContact.BusinessAddressCity, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 6), vbTextCompare) <> 0 Then
                    contContact.BusinessAddressCity = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 6)
                End If
                If StrComp(contContact.BusinessAddressCountry, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 7), vbTextCompare) <> 0 Then
                    contContact.BusinessAddressCountry = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 7)
                End If
                If StrComp(contContact.BusinessAddressPostalCode, wsExcel.ListObjects.Application.ActiveCell.Cells(i, 8), vbTextCompare) <> 0 Then
                    contContact.BusinessAddressPostalCode = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 8)
                End If
 
                contContact.Save
                contact_found = 1
                'MsgBox "Trouvé : " & contContact.LastName
                Exit Do
            End If
            lngCount = lngCount - 1
        Loop
        ' if he does not exist create him
        If contact_found = 0 Then
           Set myItem = myOlApp.CreateItem(olContactItem)
           myItem.title = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 1)
           myItem.FirstName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 2)
           myItem.LastName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 3)
           myItem.JobTitle = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 4)
           myItem.CompanyName = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 5)
           myItem.BusinessAddressCity = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 6)
           myItem.BusinessAddressCountry = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 7)
           myItem.BusinessAddressPostalCode = wsExcel.ListObjects.Application.ActiveCell.Cells(i, 8)
           myItem.Save
        End If
    Next
 
    ' on ferme l'application
    appExcel.Workbooks.Close
 
End Sub

Par exemple si j'ai 500 contacts dans Outlook et 1000 dans mon fichier le temps d'execution est affolement élevé!! N'y aurait il pas la possibilité d'optimiser le code pour que cette durée soit bien diminué ?

Merci pour votre aide !!!

[Oliv-]

Bonjour,

Essaye déjà d'insérer cette instruction.

Code :

appExcel.ScreenUpdating=false

avant ton LastRow.

Ca donne quoi ?

[ylabarre]

ça donne pareil aucun changement !! en fait c'est que je recupere un contact de mon fichier et parcours tous les contacts du carnet d'adresse Outlook et ainsi une fois le contact détecté il le met a jour et ainsi de suite pour chaque con,tact extrait du fichier.

Le temps de recherche est bien trop long !! personne a une astuce ?

Merci.

[Oliv-]

Salut,
je suis en train de tester ton code .

attention déjà contContact est défini comme Outlook.ContactItem or si dans ton dossier tu as autre chose comme une liste de distribution,ça va bloquer.

Ensuite tu fais 2 boucles imbriquées sur l'ensemble des lignes de ton fichier excel et de l'ensemble des contacts c'est bien cela ?
don si tu as 10 enregistrements tu fais 100 vérif ?

Essayes un truc comme cela :

Set contContact = fld.GetMessage(wsExcel.ListObjects.Application.ActiveCell.Cells(i, 15))

où wsExcel.ListObjects.Application.ActiveCell.Cells(i, 15) doit désigner le EntryId c'est bien cela ?

[ylabarre]

Merci pour ton aide catteau

Oui c'est bien ça! ça designe le EntryID et oui le code fera 100 tour de boucle. Je suis en train de tester une astuce qui optimise mieux le code. c'est a dire que je trie mes contacts Outlook par le nom de famille et de meme dans mon fichier ils sont triés par le nom de famille ce qui me permet de retrouver les contacts plus rapidement (mais toujours assez lent quand on a plus de 500 contacts) ....

Par contre je ne comprends pas ce que tu me conseil ? parce que si je fais cela je ne vériferai pas le contact Outlook a celui du fichier !

ps : comment dois je definir contContact si il risque d'avoir des pbs avec le Outlook.ContactItem ?

[Oliv-]

Envoyé par ylabarre

C'est a dire que je trie mes contacts Outlook par le nom de famille et de meme dans mon fichier ils sont triés par le nom de famille ce qui me permet de retrouver les contacts plus rapidement (mais toujours assez lent quand on a plus de 500 contacts) ....

Bonne idée ca va réduire le traitement,

Sinon soit tu fais une boucle à partir de excel et avec

Code :

Set contContact = fld.GetMessage(wsExcel.ListObjects.Application.ActiveCell.Cells(i, 15))

cela va te positionner sur le contact équivalent directement il faut donc connaitre le EntryId. tu peux aussi utiliser "restrict"

Code :

1
2
3
4
5
Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myContacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
    strWhere = "[Fullname] >'Oliv'"
    Set myItems = myContacts.Restrict(strWhere)

Soit tu fais le contraire une boucle à partir des contacts et là tu peux utiliser la commande find de excel.

Code :

1
2
3
    Set titre = Cells.Find(What:="Dossier client", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).EntireRow