Optimisation de code

Le 08/06/2017 à 08:13

Bonjour à tous,

J'ai créé une macro qui va rechercher des informations dans plusieurs onglets d'un même classeur. Mon problème est que son temps d'exécution est de 23 minutes...

Je cherche désespéremment à l'optimiser mais je ne trouve pas... Quelqu'un pourrait-il m'aider a trouver comment accélérer son exécution ?

Sub BuildBoard()
Dim debut As Date, temps As Date, fin As Date
    debut = Time

    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False

    ActiveWorkbook.RefreshAll

    Set ws1 = ActiveWorkbook.Sheets("TB")
    Set ws2 = ActiveWorkbook.Sheets("BDD Réitération")
    Set ws3 = ActiveWorkbook.Sheets("TCD")
    Set ws4 = ActiveWorkbook.Sheets("BDD CLT")
    Set ws5 = ActiveWorkbook.Sheets("ISA")
    Set ws6 = ActiveWorkbook.Sheets("GED")
    Set ws7 = ActiveWorkbook.Sheets("BRM")

    ws1.Cells.ClearContents

    'Init tableau
    With ws1
        .Cells(1, 1).Value = "CONTRAT"
        .Cells(1, 2).Value = "ISA"
        .Cells(1, 3).Value = "GED"
        .Cells(1, 4).Value = "BRM"
        .Cells(1, 5).Value = "CONTACT_TOTAL"
        .Cells(1, 6).Value = "NOM"
        .Cells(1, 7).Value = "PRENOM"
        .Cells(1, 8).Value = "CP"
        .Cells(1, 9).Value = "CSP"
        .Cells(1, 10).Value = "DDN"
        .Cells(1, 11).Value = "NUM_CNT"
        .Cells(1, 12).Value = "INDICE"
        .Cells(1, 13).Value = "TYPE_CONTACT 1er appel"
        .Cells(1, 14).Value = "motif 1er appel"
        .Cells(1, 15).Value = "Nombre réaffectation 1ere GED"
        .Cells(1, 16).Value = "DATE NUMERISATION 1ère GED"
        .Cells(1, 17).Value = "DATE DE RECEPTION 1ère GED"
        .Cells(1, 18).Value = "DATE CLOTURE 1ère GED"
        .Cells(1, 19).Value = "Somme Rembaxa des actes"
        .Cells(1, 20).Value = "Somme Frais réels des actes"
        .Cells(1, 21).Value = "Top si 1 règlement Annulé"
        .Cells(1, 22).Value = "RSM_C_PROV_RGL 1er règlement"
        .Cells(1, 23).Value = "BRM_SITE 1er règlement"
    End With

    'Import des contrats
    n = ws3.Range("A1000000").End(xlUp).Row - 1
    m = ws1.Range("A1000000").End(xlUp).Row + 1

    ws3.Range("A5:A" & n).Copy
    ws1.Activate
    Range("A" & m).Select
    ActiveSheet.PasteSpecial
    Application.CutCopyMode = False

    'Début de la récupération des datas
    j = ws1.Range("A1000000").End(xlUp).Row

    For i = 2 To j
        'Contacts
        ws1.Cells(i, 2).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws3.Range("A:E"), 4, 0) 'ISA
        ws1.Cells(i, 3).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws3.Range("A:E"), 3, 0) 'GED
        ws1.Cells(i, 4).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws3.Range("A:E"), 2, 0) 'BRM
        ws1.Cells(i, 5).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws3.Range("A:E"), 5, 0) 'ISA
        'FCA
        ws1.Cells(i, 6).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 2, 0) 'nom
        ws1.Cells(i, 7).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 3, 0) 'prénom
        ws1.Cells(i, 8).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 4, 0) 'cp
        ws1.Cells(i, 9).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 5, 0) 'CSP
        ws1.Cells(i, 10).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 6, 0) 'DDN
        ws1.Cells(i, 11).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 7, 0) 'num cnt
        ws1.Cells(i, 12).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws4.Range("A:H"), 8, 0) 'indice
        'ISA
        ws1.Cells(i, 13).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 1, 2) 'type contact
        ws1.Cells(i, 14).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 3, 2) 'motif
        'GED
        ws1.Cells(i, 15).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws6.Range("B:J"), 9, 0) 'nb réaffec
        ws1.Cells(i, 16).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws6.Range("B:J"), 2, 0) 'date num
        ws1.Cells(i, 17).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws6.Range("B:J"), 3, 0) 'date récep
        ws1.Cells(i, 18).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws6.Range("B:J"), 4, 0) 'date cloture
        'BRM
        ws1.Cells(i, 19).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("F:F")) 'somme remb AXA
        ws1.Cells(i, 20).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("C:C")) 'somme FR
        statut = recherche_gauche(ws1.Cells(i, 1).Value, ws7.Range("N:N"), 6, 4) 'statut règlement
        If statut = "AN" Then
            ws1.Cells(i, 21).Value = "OUI"
        Else
            ws1.Cells(i, 21).Value = "NON"
        End If
        ws1.Cells(i, 22).Value = recherche_gauche(ws1.Cells(i, 1).Value, Sheets("BRM").Range("N:N"), 1, 4) 'code provenance
        ws1.Cells(i, 23).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws7.Range("N:O"), 2, 0) 'site règlement
    Next i

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True

    fin = Time
    temps = fin - debut

    Sheets("Toolbox").Activate
    MsgBox "Le tableau de bord a bien été créé en " & temps & " minutes.", vbInformation, "Fin"

End Sub
Le 08/06/2017 à 09:21

Bonjour,

Ton fichier serait utile pour y regarder de plus près... !

Cordialement.

Le 08/06/2017 à 09:32

Merci pour ta réponse

Voici mon fichier que j'ai rendu très light du coup

Je n'arrive pas à joindre le fichier...

Le 08/06/2017 à 10:24

bonjour,

utilise cjoint

A=

Le 08/06/2017 à 10:30

Ok je le poste ce soir car je n'ai pas accès au boulot...

Merci !

Le 08/06/2017 à 10:31

Bonjour le fil, bonjour le forum,

Oui ! Je plussoie Môssieur Ferrand !... Avec une fichier c'eût été plus facile. Je te propose donc un code non testé qui devrait te renvoyer des valeurs à la place des formules et en principe aller bien plus vite....

Le code :

Sub BuildBoard()
Dim debut As Single, temps As Single, fin As Single
Dim TV As Variant, L As Long
Dim D1 As Long, D2 As Long, D3 As Long

debut = Timer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

ActiveWorkbook.RefreshAll

Set ws1 = ActiveWorkbook.Sheets("TB")
Set ws2 = ActiveWorkbook.Sheets("BDD Réitération")
Set ws3 = ActiveWorkbook.Sheets("TCD")
Set ws4 = ActiveWorkbook.Sheets("BDD CLT")
Set ws5 = ActiveWorkbook.Sheets("ISA")
Set ws6 = ActiveWorkbook.Sheets("GED")
Set ws7 = ActiveWorkbook.Sheets("BRM")

ws1.Cells.ClearContents

'Init tableau
With ws1
    .Cells(1, 1).Value = "CONTRAT"
    .Cells(1, 2).Value = "ISA"
    .Cells(1, 3).Value = "GED"
    .Cells(1, 4).Value = "BRM"
    .Cells(1, 5).Value = "CONTACT_TOTAL"
    .Cells(1, 6).Value = "NOM"
    .Cells(1, 7).Value = "PRENOM"
    .Cells(1, 8).Value = "CP"
    .Cells(1, 9).Value = "CSP"
    .Cells(1, 10).Value = "DDN"
    .Cells(1, 11).Value = "NUM_CNT"
    .Cells(1, 12).Value = "INDICE"
    .Cells(1, 13).Value = "TYPE_CONTACT 1er appel"
    .Cells(1, 14).Value = "motif 1er appel"
    .Cells(1, 15).Value = "Nombre réaffectation 1ere GED"
    .Cells(1, 16).Value = "DATE NUMERISATION 1ère GED"
    .Cells(1, 17).Value = "DATE DE RECEPTION 1ère GED"
    .Cells(1, 18).Value = "DATE CLOTURE 1ère GED"
    .Cells(1, 19).Value = "Somme Rembaxa des actes"
    .Cells(1, 20).Value = "Somme Frais réels des actes"
    .Cells(1, 21).Value = "Top si 1 règlement Annulé"
    .Cells(1, 22).Value = "RSM_C_PROV_RGL 1er règlement"
    .Cells(1, 23).Value = "BRM_SITE 1er règlement"
End With

'Import des contrats
n = ws3.Range("A1000000").End(xlUp).Row - 1
m = ws1.Range("A1000000").End(xlUp).Row + 1

ws3.Range("A5:A" & n).Copy ws1.Range("A" & m)

'Début de la récupération des datas
j = ws1.Range("A1000000").End(xlUp).Row

For i = 2 To j

    'Contacts
    TV = ws3.Range("A1").CurrentRegion
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 2) = TV(L, 4) 'ISA sans formule
            ws1.Cells(i, 3) = TV(L, 3) 'GED sans formule
            ws1.Cells(i, 4) = TV(L, 2) 'BRM sans formule
            ws1.Cells(i, 5) = TV(L, 5) 'ISA sans formule
            Exit For
        End If
    Next L

    'FCA
    TV = ws4.Range("A1").CurrentRegion
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 6) = TV(L, 2) 'nom sans formule
            ws1.Cells(i, 7) = TV(L, 3) 'prénom sans formule
            ws1.Cells(i, 8) = TV(L, 4) 'cp sans formule
            ws1.Cells(i, 9) = TV(L, 5) 'CSP sans formule
            ws1.Cells(i, 10) = TV(L, 6) 'DDN sans formule
            ws1.Cells(i, 11) = TV(L, 7) 'num cnt sans formule
            ws1.Cells(i, 12) = TV(L, 8) 'indice sans formule
            Exit For
        End If
    Next L

    'ISA
    'recherche_gauche doit être une fonction personnalisée ?...
    ws1.Cells(i, 13).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 1, 2) 'type contact
    ws1.Cells(i, 14).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 3, 2) 'motif

    'GED
    TV = ws6.Range("B1").CurrentRegion 
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 15) = TV(L, 9) 'nb éaffec sans formule (remplace 9 par 10 si la colonne A n'est pas vide)
            D1 = DateSerial(Year(TV(L, 2)), Month(TV(L, 2)), Day(TV(L, 2)))
            ws1.Cells(i, 16) = D1 'date num sans formule
            D2 = DateSerial(Year(TV(L, 3)), Month(TV(L, 3)), Day(TV(L, 3)))
            ws1.Cells(i, 17) = D2 'date récep sans formule
            D3 = DateSerial(Year(TV(L, 4)), Month(TV(L, 4)), Day(TV(L, 4)))
            ws1.Cells(i, 18) = D3 'date cloture sans formule
            Exit For
        End If
    Next L

    'BRM
    ws1.Cells(i, 19).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("F:F")) 'somme remb AXA
    ws1.Cells(i, 20).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("C:C")) 'somme FR
    statut = recherche_gauche(ws1.Cells(i, 1).Value, ws7.Range("N:N"), 6, 4) 'statut règlement
    If statut = "AN" Then
        ws1.Cells(i, 21).Value = "OUI"
    Else
        ws1.Cells(i, 21).Value = "NON"
    End If
    ws1.Cells(i, 22).Value = recherche_gauche(ws1.Cells(i, 1).Value, Sheets("BRM").Range("N:N"), 1, 4) 'code provenance
    ws1.Cells(i, 23).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws7.Range("N:O"), 2, 0) 'site règlement
Next i
ws1.Columns("P:R").NumberFormat = "dd/mm/yyyy" 'format à adapter

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Sheets("Toolbox").Activate

temps = Timer - debut
MsgBox "Le tableau de bord a bien été créé en " & temps & " secondes.", vbInformation, "Fin"

End Sub
Le 08/06/2017 à 10:36

Salut ThauThème...

C'est parce que vu quelques lignes qu'il me semble mieux de voir avec fichier... Mais je vais m'absenter pour le reste de la journée, on verra plus tard.

Le 08/06/2017 à 20:38

Voilà le fichier

https://www.cjoint.com/c/GFisLIsTNxY

ThauThème a écrit :

Bonjour le fil, bonjour le forum,

Oui ! Je plussoie Môssieur Ferrand !... Avec une fichier c'eût été plus facile. Je te propose donc un code non testé qui devrait te renvoyer des valeurs à la place des formules et en principe aller bien plus vite....

Le code :

Sub BuildBoard()
Dim debut As Single, temps As Single, fin As Single
Dim TV As Variant, L As Long
Dim D1 As Long, D2 As Long, D3 As Long

debut = Timer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

ActiveWorkbook.RefreshAll

Set ws1 = ActiveWorkbook.Sheets("TB")
Set ws2 = ActiveWorkbook.Sheets("BDD Réitération")
Set ws3 = ActiveWorkbook.Sheets("TCD")
Set ws4 = ActiveWorkbook.Sheets("BDD CLT")
Set ws5 = ActiveWorkbook.Sheets("ISA")
Set ws6 = ActiveWorkbook.Sheets("GED")
Set ws7 = ActiveWorkbook.Sheets("BRM")

ws1.Cells.ClearContents

'Init tableau
With ws1
    .Cells(1, 1).Value = "CONTRAT"
    .Cells(1, 2).Value = "ISA"
    .Cells(1, 3).Value = "GED"
    .Cells(1, 4).Value = "BRM"
    .Cells(1, 5).Value = "CONTACT_TOTAL"
    .Cells(1, 6).Value = "NOM"
    .Cells(1, 7).Value = "PRENOM"
    .Cells(1, 8).Value = "CP"
    .Cells(1, 9).Value = "CSP"
    .Cells(1, 10).Value = "DDN"
    .Cells(1, 11).Value = "NUM_CNT"
    .Cells(1, 12).Value = "INDICE"
    .Cells(1, 13).Value = "TYPE_CONTACT 1er appel"
    .Cells(1, 14).Value = "motif 1er appel"
    .Cells(1, 15).Value = "Nombre réaffectation 1ere GED"
    .Cells(1, 16).Value = "DATE NUMERISATION 1ère GED"
    .Cells(1, 17).Value = "DATE DE RECEPTION 1ère GED"
    .Cells(1, 18).Value = "DATE CLOTURE 1ère GED"
    .Cells(1, 19).Value = "Somme Rembaxa des actes"
    .Cells(1, 20).Value = "Somme Frais réels des actes"
    .Cells(1, 21).Value = "Top si 1 règlement Annulé"
    .Cells(1, 22).Value = "RSM_C_PROV_RGL 1er règlement"
    .Cells(1, 23).Value = "BRM_SITE 1er règlement"
End With

'Import des contrats
n = ws3.Range("A1000000").End(xlUp).Row - 1
m = ws1.Range("A1000000").End(xlUp).Row + 1

ws3.Range("A5:A" & n).Copy ws1.Range("A" & m)

'Début de la récupération des datas
j = ws1.Range("A1000000").End(xlUp).Row

For i = 2 To j

    'Contacts
    TV = ws3.Range("A1").CurrentRegion
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 2) = TV(L, 4) 'ISA sans formule
            ws1.Cells(i, 3) = TV(L, 3) 'GED sans formule
            ws1.Cells(i, 4) = TV(L, 2) 'BRM sans formule
            ws1.Cells(i, 5) = TV(L, 5) 'ISA sans formule
            Exit For
        End If
    Next L

    'FCA
    TV = ws4.Range("A1").CurrentRegion
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 6) = TV(L, 2) 'nom sans formule
            ws1.Cells(i, 7) = TV(L, 3) 'prénom sans formule
            ws1.Cells(i, 8) = TV(L, 4) 'cp sans formule
            ws1.Cells(i, 9) = TV(L, 5) 'CSP sans formule
            ws1.Cells(i, 10) = TV(L, 6) 'DDN sans formule
            ws1.Cells(i, 11) = TV(L, 7) 'num cnt sans formule
            ws1.Cells(i, 12) = TV(L, 8) 'indice sans formule
            Exit For
        End If
    Next L

    'ISA
    'recherche_gauche doit être une fonction personnalisée ?...
    ws1.Cells(i, 13).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 1, 2) 'type contact
    ws1.Cells(i, 14).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 3, 2) 'motif

    'GED
    TV = ws6.Range("B1").CurrentRegion 
    For L = 1 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 1) Then
            ws1.Cells(i, 15) = TV(L, 9) 'nb éaffec sans formule (remplace 9 par 10 si la colonne A n'est pas vide)
            D1 = DateSerial(Year(TV(L, 2)), Month(TV(L, 2)), Day(TV(L, 2)))
            ws1.Cells(i, 16) = D1 'date num sans formule
            D2 = DateSerial(Year(TV(L, 3)), Month(TV(L, 3)), Day(TV(L, 3)))
            ws1.Cells(i, 17) = D2 'date récep sans formule
            D3 = DateSerial(Year(TV(L, 4)), Month(TV(L, 4)), Day(TV(L, 4)))
            ws1.Cells(i, 18) = D3 'date cloture sans formule
            Exit For
        End If
    Next L

    'BRM
    ws1.Cells(i, 19).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("F:F")) 'somme remb AXA
    ws1.Cells(i, 20).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("C:C")) 'somme FR
    statut = recherche_gauche(ws1.Cells(i, 1).Value, ws7.Range("N:N"), 6, 4) 'statut règlement
    If statut = "AN" Then
        ws1.Cells(i, 21).Value = "OUI"
    Else
        ws1.Cells(i, 21).Value = "NON"
    End If
    ws1.Cells(i, 22).Value = recherche_gauche(ws1.Cells(i, 1).Value, Sheets("BRM").Range("N:N"), 1, 4) 'code provenance
    ws1.Cells(i, 23).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws7.Range("N:O"), 2, 0) 'site règlement
Next i
ws1.Columns("P:R").NumberFormat = "dd/mm/yyyy" 'format à adapter

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Sheets("Toolbox").Activate

temps = Timer - debut
MsgBox "Le tableau de bord a bien été créé en " & temps & " secondes.", vbInformation, "Fin"

End Sub

Merci pour le code mais j'ai un message d'erreur au niveau des boucles...

Le 09/06/2017 à 08:57

Re,

Le fichier fourni ne correspond pas au code !... Bug sur :

Set ws2 = ActiveWorkbook.Sheets("BDD Réitération")
Set ws3 = ActiveWorkbook.Sheets("TCD")

Je reprendrai mes tests avec un bon fichier....

Le 10/06/2017 à 10:02

Bonjour,

Voici le fichier complet

https://www.cjoint.com/c/GFkictIQPbY

Le 11/06/2017 à 11:58

Re,

Le code modifié :

Sub BuildBoard()
Dim debut As Single, temps As Single, fin As Single
Dim TV As Variant, L As Long
Dim D1 As Long, D2 As Long, D3 As Long

debut = Timer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

ActiveWorkbook.RefreshAll

Set ws1 = ActiveWorkbook.Sheets("TB")
Set ws2 = ActiveWorkbook.Sheets("BDD Réitération")
Set ws3 = ActiveWorkbook.Sheets("TCD")
Set ws4 = ActiveWorkbook.Sheets("BDD CLT")
Set ws5 = ActiveWorkbook.Sheets("ISA")
Set ws6 = ActiveWorkbook.Sheets("GED")
Set ws7 = ActiveWorkbook.Sheets("BRM")

ws1.Cells.ClearContents

'Init tableau
With ws1
.Cells(1, 1).Value = "CONTRAT"
.Cells(1, 2).Value = "ISA"
.Cells(1, 3).Value = "GED"
.Cells(1, 4).Value = "BRM"
.Cells(1, 5).Value = "CONTACT_TOTAL"
.Cells(1, 6).Value = "NOM"
.Cells(1, 7).Value = "PRENOM"
.Cells(1, 8).Value = "CP"
.Cells(1, 9).Value = "CSP"
.Cells(1, 10).Value = "DDN"
.Cells(1, 11).Value = "NUM_CNT"
.Cells(1, 12).Value = "INDICE"
.Cells(1, 13).Value = "TYPE_CONTACT 1er appel"
.Cells(1, 14).Value = "motif 1er appel"
.Cells(1, 15).Value = "Nombre réaffectation 1ere GED"
.Cells(1, 16).Value = "DATE NUMERISATION 1ère GED"
.Cells(1, 17).Value = "DATE DE RECEPTION 1ère GED"
.Cells(1, 18).Value = "DATE CLOTURE 1ère GED"
.Cells(1, 19).Value = "Somme Rembaxa des actes"
.Cells(1, 20).Value = "Somme Frais réels des actes"
.Cells(1, 21).Value = "Top si 1 règlement Annulé"
.Cells(1, 22).Value = "RSM_C_PROV_RGL 1er règlement"
.Cells(1, 23).Value = "BRM_SITE 1er règlement"
End With

'Import des contrats
n = ws3.Range("A1000000").End(xlUp).Row - 2
m = ws1.Range("A1000000").End(xlUp).Row + 1

ws3.Range("A5:A" & n).Copy ws1.Range("A" & m)

'Début de la récupération des datas
j = ws1.Range("A1000000").End(xlUp).Row

For i = 2 To j

    'Contacts
    TV = ws3.Range("A5:F" & ws3.Cells(Application.Rows.Count, "A").End(xlUp).Row - 2)
    For L = 1 To UBound(TV, 1)
    If ws1.Cells(i, 1) = TV(L, 1) Then
        ws1.Cells(i, 2) = TV(L, 4) 'ISA sans formule
        ws1.Cells(i, 3) = TV(L, 3) 'GED sans formule
        ws1.Cells(i, 4) = TV(L, 2) 'BRM sans formule
        ws1.Cells(i, 5) = TV(L, 5) 'ISA sans formule
        Exit For
    End If
    Next L

    'FCA
    TV = ws4.Range("A1").CurrentRegion
    For L = 2 To UBound(TV, 1)
    If ws1.Cells(i, 1) = TV(L, 1) Then
        ws1.Cells(i, 6) = TV(L, 2) 'nom sans formule
        ws1.Cells(i, 7) = TV(L, 3) 'prénom sans formule
        ws1.Cells(i, 8) = TV(L, 4) 'cp sans formule
        ws1.Cells(i, 9) = TV(L, 5) 'CSP sans formule
        ws1.Cells(i, 10) = TV(L, 6) 'DDN sans formule
        ws1.Cells(i, 11) = TV(L, 7) 'num cnt sans formule
        ws1.Cells(i, 12) = TV(L, 8) 'indice sans formule
        Exit For
    End If
    Next L

    'ISA
    'recherche_gauche doit être une fonction personnalisée ?...
    ws1.Cells(i, 13).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 1, 2) 'type contact
    ws1.Cells(i, 14).Value = recherche_gauche(ws1.Cells(i, 1).Value, ws5.Range("G:G"), 3, 2) 'motif

    'GED
    TV = ws6.Range("B1").CurrentRegion
    For L = 2 To UBound(TV, 1)
        If ws1.Cells(i, 1) = TV(L, 2) Then
            ws1.Cells(i, 15) = TV(L, 9) 'nb éaffec sans formule (remplace 9 par 10 si la colonne A n'est pas vide)
            D1 = DateSerial(Year(TV(L, 3)), Month(TV(L, 3)), Day(TV(L, 3)))
            ws1.Cells(i, 16) = D1 'date num sans formule
            D2 = DateSerial(Year(TV(L, 4)), Month(TV(L, 4)), Day(TV(L, 4)))
            ws1.Cells(i, 17) = D2 'date récep sans formule
            D3 = DateSerial(Year(TV(L, 5)), Month(TV(L, 5)), Day(TV(L, 5)))
            ws1.Cells(i, 18) = D3 'date cloture sans formule
            Exit For
        End If
    Next L

    'BRM
    ws1.Cells(i, 19).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("F:F")) 'somme remb AXA
    ws1.Cells(i, 20).Value = Application.WorksheetFunction.SumIf(ws7.Range("N:N"), ws1.Cells(i, 1).Value, ws7.Range("C:C")) 'somme FR
    statut = recherche_gauche(ws1.Cells(i, 1).Value, ws7.Range("N:N"), 6, 4) 'statut règlement
    If statut = "AN" Then
        ws1.Cells(i, 21).Value = "OUI"
    Else
        ws1.Cells(i, 21).Value = "NON"
    End If
    ws1.Cells(i, 22).Value = recherche_gauche(ws1.Cells(i, 1).Value, Sheets("BRM").Range("N:N"), 1, 4) 'code provenance
    ws1.Cells(i, 23).Value = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1).Value, ws7.Range("N:O"), 2, 0) 'site règlement
Next i

ws1.Columns("P:R").NumberFormat = "dd/mm/yyyy" 'format à adapter

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Sheets("Toolbox").Activate

temps = Timer - debut
MsgBox "Le tableau de bord a bien été créé en " & temps & " secondes.", vbInformation, "Fin"

End Sub

Mais avec le peu de données fournies dans ton exemple, ton code est plus rapide que le mien... À vérifier sur un fichier long.

Le 11/06/2017 à 15:28

Re,

Merci pour ta proposition je vais tester ça demain et je te redis

A+

Le 12/06/2017 à 15:46

Bonjour,

J'ai testé le code mais il prends plus de temps que celui que j'avais écris à l'origine...

A+

Le 12/06/2017 à 16:16

Re,

Oui, c'est ce que je t'avais signalé aussi... désolé !

Rechercher des sujets similaires à "optimisation code"