[VBA] - Vitesse d'exécution code VBA

Bonjour,

Pour une partie du traitement des données sur Excel, j'utilise un code qui met un peu de temps à s'exécuter. Tout est pratiquement terminé et je cherche désormais à optimiser un peu tout ça pour que ça tourne plus vite (notamment sur des machine un peu moins récentes).

Après plusieurs tests, pour 70 lignes le code peut mettre jusqu'à 1min10 à se terminer.

Mais il peut y avoir bien plus de lignes.

Sub 1 (structabBDD) : < 1 sec

Sub 2 (Rechnum) : 13sec30

Sub 3 (structab) : < 1 sec

Sub 4 (CorrCodes) : 54 sec

Sub 5 (style) : 1 sec

Sub 6 (RechErr) : < 1 sec

Comme vous pouvez le constater, le code qui met le plus de temps à s'exécuter est le sub CorrCodes () qui pourtant est très loin d'être le plus complexe !

Voici le code dans son ensemble :

Private Sub CommandButton1_Click() 'KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'If KeyCode = 13 Then CommandButton1_Click

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")

Dim valtab As Long
valtab = Application.WorksheetFunction.CountBlank(co.Range("A1:J10"))
If valtab < 100 Then Rep = MsgBox("Des données sont déjà présentes dans le tableau, Voulez-vous nettoyer les données ?", vbYesNo + vbExclamation, "Tableau existant")
    If Rep = vbYes Then
        co.Cells.ClearContents
        co.Cells.Interior.ColorIndex = xlColorIndexNone
            structabBDD
            Rechnum
            structab
            CorrCodes
            style
            RechErr
        If Rep = vbNo Then
    structabBDD
    Rechnum
    structab
    CorrCodes
    style
    RechErr
    End If
Else
    structabBDD
    Rechnum
    structab
    CorrCodes
    style
    RechErr
End If

End Sub
Option Explicit

Dim n As String, Rep As Byte
Dim lrfb As Long, lrco As Long, lrsa As Long, lrdc As Long, r As Long
Dim fb As Worksheet, sa As Worksheet, dc As Worksheet, ds As Worksheet, co As Worksheet
Dim rng As Range, cell As Range, rng2 As Range, Cell2 As Range
Dim i&, derLn&, nb&, derLn2&, nb2&
Dim del As Integer

structabBDD

Sub structabBDD()

    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With dc
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_complète"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_complete"
        End If
    End With
    With ds
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_synonymes"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_synonymes"
        End If
    End With
End Sub

Rechnum

Sub Rechnum()

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")
Set dc = Worksheets("Database complete")
Set ds = Worksheets("Database synonymes complete")

        Dim Lig As Long
        Dim Col As String
        Dim NbrLig As Long
        Dim NumLig As Long

            co.Cells(1, 1).Value = sa.Cells(1, 1).Value
            co.Cells(1, 2).Value = fb.Cells(1, 4).Value
            co.Cells(1, 3).Value = sa.Cells(1, 4).Value
            Cells(1, 4).Value = "Correspondance"
            co.Cells(1, 5).Value = sa.Cells(1, 5).Value
            co.Cells(1, 6).Value = sa.Cells(1, 6).Value
            co.Cells(1, 7).Value = fb.Cells(1, 5).Value
            co.Cells(1, 8).Value = fb.Cells(1, 6).Value
            co.Cells(1, 9).Value = fb.Cells(1, 16).Value
            co.Cells(1, 10).Value = fb.Cells(1, 17).Value
            co.Cells(1, 11).Value = fb.Cells(1, 12).Value
            co.Cells(1, 12).Value = fb.Cells(1, 13).Value

                lrfb = fb.Cells(Rows.Count, 1).End(xlUp).Row
                lrsa = sa.Cells(Rows.Count, 1).End(xlUp).Row

                Dim vari As Range, plge As Range

                'Remplissage de la colonne [A] (Parrent row ID)
                'Remplissage de la colonne [C] (espece)
                     With sa
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
                        'Plage à copier
                        Set rng = .Cells(1, 1).Resize(lrsa + 1)
                        Set rng2 = .Cells(1, 4).Resize(lrsa + 1)
                    End With

                    With co
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
                        Set cell = .Cells(lrsa, 1)
                        Set Cell2 = .Cells(lrsa, 3)
                    End With

                    rng.Copy Destination:=cell
                    rng2.Copy Destination:=Cell2

                    With co
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                        'plage de cellules
                        Set rng = .Cells(1, 1).Resize(lrsa - 1)
                        Set rng2 = .Cells(1, 3).Resize(lrsa - 1)
                    End With

                'Remplissage de la colonne [B] (Numéro étude)
                Dim i1 As Integer, num1 As Variant
                With Worksheets("Correspondances")
                lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
                For i1 = 2 To lrco
                On Error Resume Next
                  num1 = Application.WorksheetFunction.VLookup(.Cells(i1, 1), Sheets("Formulaire bota").Range("A:D"), 4, 0)
                  .Cells(i1, 2) = IIf(IsError(num1), 0, num1)
                Next
                End With

                'Conserver les valeurs recherchées (num étude)
                    With co
                        For del = co.Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
                            If .Range("B" & del).Value <> n Then
                            .Rows(del).Delete
                            End If
                        Next del
                    End With

                'Remplissage de la colonne [E] (abondance)
                'Remplissage de la colonne [F] (remarque)
                'Remplissage de la colonne [C] (especes) (désactivé)
                Dim i2 As Integer, num2 As Variant, num3 As Variant, num4 As Variant
                    With Worksheets("Correspondances")
                        lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
                        For i2 = 2 To lrco
                        On Error Resume Next
                            num2 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:E"), 5, 0)
                            .Cells(i2, 5) = IIf(IsError(num2), 0, num2)
                            num3 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:F"), 6, 0)
                            .Cells(i2, 6) = IIf(IsError(num3), 0, num3)
                            'num4 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:D"), 4, 0)
                            '.Cells(i2, 3) = IIf(IsError(num4), 0, num4)
                        Next
                    End With

                'Remplissage de la colonne [G] (cortege)
                'Remplissage de la colonne [H] (autres_infos)
                'Remplissage de la colonne [I] (x)
                'Remplissage de la colonne [J] (y)
                'Remplissage de la colonne [K] (created_date)
                'Remplissage de la colonne [L] (created_user)
                Dim num5 As Variant, num6 As Variant, num7 As Variant, num8 As Variant, num9 As Variant, num10 As Variant

                    With Worksheets("Correspondances")
                        For i2 = 2 To lrco
                        co.Cells(i2, 11).NumberFormat = "dd/mm/yyyy;@"
                        co.Cells(i2, 10).NumberFormat = "General"
                        co.Cells(i2, 2).NumberFormat = "@"

                        On Error Resume Next
                            num5 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:E"), 5, 0)
                            .Cells(i2, 7) = IIf(IsError(num5), 0, num5)
                            num6 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:F"), 6, 0)
                            .Cells(i2, 8) = IIf(IsError(num6), 0, num6)
                            num7 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:G"), 7, 0)
                            .Cells(i2, 11) = IIf(IsError(num7), 0, num7)
                            num8 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:M"), 13, 0)
                            .Cells(i2, 12) = IIf(IsError(num8), 0, num8)
                            num9 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:P"), 16, 0)
                            .Cells(i2, 9) = IIf(IsError(num9), 0, num9)
                            num10 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:Q"), 17, 0)
                            .Cells(i2, 10) = IIf(IsError(num10), 0, num10)
                        Next
                    End With

                'Retirer l'heure de la date
                Dim Nc, Cib As Range
                    For Each Cib In Range("K2:K" & lrco)
                        Cib.Value = Trim(Cib.Value) 'supprime espaces
                        Nc = Len(Cib)               'compte les caractères
                        If Len(Cib.Value) > 10 Then Cib.Value = Left(Cib, Nc - 9)
                    Next Cib

                'Compéter la nouvelle colonne "correspondances"
                Dim ii As Integer, vv As Variant
                    Set dc = Sheets("Database complete")
                    Set ds = Sheets("Database synonymes complete")
                    derLn = dc.Range("A" & Rows.Count).End(xlUp).Row
                    derLn2 = ds.Range("A" & Rows.Count).End(xlUp).Row

                    For ii = 2 To co.Range("A" & Rows.Count).End(xlUp).Row
                    Cells(1, 14).Value = ii
                        nb = WorksheetFunction.CountIfs(dc.Range("A2:A" & derLn), co.Range("C" & ii))
                        nb2 = WorksheetFunction.CountIfs(ds.Range("B2:B" & derLn2), co.Range("C" & ii))
                        If nb = 0 Then
                            If nb2 > 0 Then
                                co.Range("D" & ii) = "Synonymes"
                            ElseIf nb2 = 0 Then
                            co.Range("D" & ii) = "Code erroné"
                            End If
                        ElseIf nb = 2 Then
                            co.Range("D" & ii) = "Codes jumeaux"
                        ElseIf nb = 1 And nb < 2 And nb <> 0 Then
                            On Error Resume Next
                            vv = Application.WorksheetFunction.VLookup(co.Cells(ii, 3), Sheets("Database complete").Range("A:G"), 7, 0)
                            co.Cells(ii, 4) = IIf(IsError(vv), 0, vv)
                        End If
                    Next ii

                Unload UserForm4
End Sub

structab

Sub structab()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With co
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Correspondances"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Correspondances"
        End If
    End With
End Sub

CorrCodes

Sub CorrCodes()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim lrco As Long

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
Dim supspa As Range
    For Each supspa In Sheets("Correspondances").Range("C1:C" & lrco)
        supspa.Value = Trim(supspa.Value) 'RTrim = suppr espace en fin de chaine ; LTrim en début de chaine
    Next supspa

Dim modssp As Long
    For modssp = 2 To lrco
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "subsp.", "ssp.")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "subsp", "ssp.")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "..", ".")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "var", "var.")

    Next modssp
End Sub

style

Sub style()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    Dim a As Integer

        For a = 2 To lrco
            If co.Cells(a, 4) = "Code erroné" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(204, 51, 0)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(255, 255, 255)
            Else
                If co.Cells(a, 4) = "Codes jumeaux" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(255, 255, 102)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                Else
                    If co.Cells(a, 4) = "Synonymes" Then
                    co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(71, 185, 182)
                    co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                    Else
                        If co.Cells(a, 4) <> "Synonymes" Or co.Cells(a, 4) <> "Code erroné" Or co.Cells(a, 4) <> "Codes jumeaux" Then
                        co.Range(Cells(a, 4), Cells(a, 4)).Interior.ColorIndex = xlColorIndexNone
                        co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                        End If
                    End If
                End If
            End If
        Next a

End Sub

RechErr

Sub RechErr()

Set co = Worksheets("Correspondances")
lrco = co.Cells(Rows.Count, 1).End(xlUp).Row

    Dim Plageb As Range
    Dim Cibleb, Cible2b, Cible3b
    Set Plageb = co.Range("D1:D" & lrco)
    On Error Resume Next
    Cibleb = Application.WorksheetFunction.CountIf(Plageb, "=Code erroné")
    Cible2b = Application.WorksheetFunction.CountIf(Plageb, "=Codes jumeaux")
    Cible3b = Application.WorksheetFunction.CountIf(Plageb, "=Synonymes")
    If Cibleb + Cible2b + Cible3b > 0 Then UserForm3.Show

End Sub

Je n'ai pas mis mon document Excel, mais si vous jugez que ce serait plus clair de travailler sur un document Excel, alors j'en créerai un plus léger, celui que j'utilise est un peu trop volumineux.

Est-ce que vous pensez qu'il est possible de faire quelque chose qui s'exécute plus vite ?

Je suis curieux aussi de ne plus déclarer les colonnes traitées par leur numéro mais par leur nom, de manière à ce qu'en cas de modification du tableau initial, le code soit capable de s’exécuter encore. Il faut variabiliser le tableau si j'ai bien compris. Je vais regarder ça..

Merci de votre attention

Bonne journée !

Bonjour à tous,

A première vue, tu devrais travailler sur des tableaux (tu mets C2:Clrco dans un tableau), tu travailles avec tes replace successifs sur le tableau et tu rapatries le résultat du tableau en C2:Clrco.

Ça devrait être immédiat en temps de réponse.

Cordialement

Bonjour,

C'est pas le nombre de ligne de code qu'il faut compter, mais le nombre de ligne de lrco : Dans une boucle For... Next ça fait un malheur !

On ne peut que confirmer qu'il faut travailler sur un Array dès que tu rentres dans une boucle For..Next

A+

Bonjour,

J'ai modifié le code comme ceci :

Dim val As Range, val1 As Range, val2 As Range, val3 As Range
    With co.Columns("C:C")
        Set val = .Find("subsp.", LookIn:=xlValues)
        For Each val In co.Range("C1:C" & lrco)
        val.Value = Replace(val, "subsp.", "ssp.")
        Next val

        Set val1 = .Find("subsp", LookIn:=xlValues)
        For Each val1 In co.Range("C1:C" & lrco)
        val1.Value = Replace(val1, "subsp", "ssp.")
        Next val1

        Set val2 = .Find("subsp", LookIn:=xlValues)
        For Each val2 In Sheets("Correspondances").Range("C1:C" & lrco)
        val2.Value = Replace(val2, "..", ".")
        Next val2

        Set val3 = .Find("subsp", LookIn:=xlValues)
        For Each val3 In Sheets("Correspondances").Range("C1:C" & lrco)
        val3.Value = Replace(val3, "var", "var.")
        Next val3
    End With

Désormais le tout s'exécute en 50sec.

Je vais tester ce que vous proposez.

Bonjour Le Drosophile

Je n'ai pas tout suivi, mais pourquoi faire une boucle pour remplacer une valeur par une autre

Pour moi, il suffit de faire

    Columns("C:C").Replace What:="subsp.", Replacement:="ssp.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

A+

En effet, avec cette simple modification, l'exécution du code passe de 1min10 à 17sec !

Merci !

Je vais zieuter du côté des boucles pour voir si je peux mieux faire.

Bonjour,

Je reviens vers vous maintenant que la totalité du code est achevé, pour voir si n'auriez pas d'autres solutions pour réduire la vitesse d'exécution de celui-ci.

Depuis la dernière fois, j'ai rajouté ce qu'il manquait et pour réduire le temps d'exécution, j'ai ajouté une fenêtre d'options qui permet de choisir les traitements à faire, histoire de pas tout refaire quand il n'y a pas spécialement besoin.

Voici comment celui-ci se présente :

(Option Explicit)

Option Explicit
Dim n As Long, Rep As Byte
Dim lrfb As Long, lrco As Long, lrsa As Long, r As Long
Dim fb As Worksheet, sa As Worksheet, dc As Worksheet, ds As Worksheet, co As Worksheet
Dim rng As Range, cell As Range, rng2 As Range, Cell2 As Range
Dim i&, derLn&, nb&, derLn2&, nb2&
Dim del As Integer

De ce UserForm sont lancé tous les modules à la suite.

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")

verifetude

Application.ScreenUpdating = False

Dim valtab As Long
valtab = Application.WorksheetFunction.CountBlank(co.Range("A1:J10"))

    If TextBox1.Value = 0 Or TextBox1.Value = "" Then
    Exit Sub
    End If

    If valtab < 100 Then Rep = MsgBox("Des données sont déjà présentes dans le tableau, Voulez-vous nettoyer les données ?", vbYesNo + vbExclamation, "Tableau existant")
        If Rep = vbYes Then
            co.Cells.ClearContents
            co.Cells.Interior.ColorIndex = xlColorIndexNone
                structabBDD
                Rechnumincomplete
                DeleteBlankColumns
                structab
                CorrCodes
                supprvide
                    If CheckBox1.Value = True Then
                        sumdel
                    End If
                    If CheckBox2.Value = True Then
                        CorrectAuto
                    End If
                corresp
            Application.ScreenUpdating = True
                style
                RechErr
        If Rep = vbNo Then
                structabBDD
                Rechnumincomplete
                DeleteBlankColumns
                structab
                CorrCodes
                supprvide
                    If CheckBox1.Value = True Then
                        sumdel
                    End If
                    If CheckBox2.Value = True Then
                        CorrectAuto
                    End If
                corresp
            Application.ScreenUpdating = True
                style
                RechErr
            End If

    ElseIf valtab = 100 Then
        structabBDD
        Rechnumincomplete
        DeleteBlankColumns
        structab
        CorrCodes
        supprvide
            If CheckBox1.Value = True Then
                    sumdel
            End If
            If CheckBox2.Value = True Then
                    CorrectAuto
            End If
        corresp
    Application.ScreenUpdating = True
        style
        RechErr
    End If

End Sub

(Option Explicit)

Option Explicit
Dim n As String, Rep As Byte
Dim lrfb As Long, lrco As Long, lrsa As Long, lrdc As Long, r As Long, lrCBN As Long, lran As Long
Dim lcco As Long, lcan As Long
Dim fb As Worksheet, sa As Worksheet, dc As Worksheet, ds As Worksheet, co As Worksheet, an As Worksheet, CBN As Worksheet
Dim rng As Range, cell As Range, rng2 As Range, Cell2 As Range
Dim rng3 As Range, rng4 As Range, rng5 As Range, rng6 As Range, rng7 As Range, rng8 As Range
Dim Cell3 As Range, Cell4 As Range, Cell5 As Range, Cell6 As Range, Cell7 As Range, Cell8 As Range
Dim i&, derLn&, nb&, derLn2&, nb2&
Dim del As Integer

structabBDD (Rapide)

Sub structabBDD()

    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With dc
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_complète"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_complete"
        End If
    End With
    With ds
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_synonymes"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_synonymes"
        End If
    End With
End Sub

Rechnumincomplete (Moyen)

Sub Rechnumincomplete()
Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")
Set dc = Worksheets("Database complete")
Set ds = Worksheets("Database synonymes complete")

    Dim Lig As Long, NbrLig As Long, NumLig As Long
    Dim Col As String
    Dim plagebota As Range, plagesaisie As Range, re As Range

        lrfb = fb.Cells(Rows.Count, 1).End(xlUp).Row
        lrsa = sa.Cells(Rows.Count, 1).End(xlUp).Row

    Dim vari As Range, plge As Range

    'Remplissage de la colonne [A] (Parrent row ID)
    'Remplissage de la colonne [C] (espece)
    'Remplissage de la colonne [M] (Global ID)
    With sa
        'dernière ligne non vide de la colonne A
        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
        'Plage à copier
        Set rng = .Cells(1, 6).Resize(lrsa)
        Set rng2 = .Cells(1, 3).Resize(lrsa)
        Set rng8 = .Cells(1, 2).Resize(lrsa)
    End With

    With co
        'dernière ligne non vide de la colonne A
        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set cell = .Cells(lrsa, 1)
        Set Cell2 = .Cells(lrsa, 3)
        Set Cell8 = .Cells(lrsa, 13)
    End With

        rng.Copy Destination:=cell
        rng2.Copy Destination:=Cell2
        rng8.Copy Destination:=Cell8

    With co
        'dernière ligne non vide de la colonne A
        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        'plage de cellules
        Set rng = .Cells(1, 1).Resize(lrsa)
        Set rng2 = .Cells(1, 3).Resize(lrsa)
        Set rng8 = .Cells(1, 13).Resize(lrsa)
    End With

    'Remplissage de la colonne [B] (Numéro étude)
    Dim i1 As Integer, num1 As Variant
    Set plagebota = fb.Range("A1:A" & fb.Cells(Rows.Count, 1).End(xlUp).Row)
    With co
        lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
        For i1 = 2 To lrco
            Set re = plagebota.Find(.Cells(i1, 1), LookAt:=xlWhole)
            If Not re Is Nothing Then
                .Cells(i1, 2) = re.Offset(, 3)
            Else
                .Cells(i1, 2) = 0    'numéro étude
            End If
        Next
    End With

   'Conserver les valeurs recherchées (num étude)
   With co
        For del = co.Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If .Range("B" & del).Value <> n Then
                .Rows(del).delete
            End If
        Next del
    End With

    'Remplissage de la colonne [E] (abondance)(Checkbox1)
    'Remplissage de la colonne [F] (remarque)(Checkbox2)
    Dim i2 As Integer, num2 As Variant, num3 As Variant, num4 As Variant

    Set plagesaisie = sa.Range("F1:F" & sa.Cells(Rows.Count, 6).End(xlUp).Row)

    lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
    With co
        For i2 = 2 To lrco
            Set re = plagesaisie.Find(.Cells(i2, 1), LookAt:=xlWhole)
            If Not re Is Nothing Then
                If UserForm13.CheckBox1 = True Then
                    co.Cells(1, 5).Value = sa.Cells(1, 4).Value
                    .Cells(i2, 5) = re.Offset(i2 - 2, -2)  'abondance
                End If
                 If UserForm13.CheckBox2 = True Then
                    co.Cells(1, 6).Value = sa.Cells(1, 5).Value
                    .Cells(i2, 6) = re.Offset(i2 - 2, -1)  'remarque
                End If
            Else
                    .Cells(i2, 5) = ""
                    .Cells(i2, 6) = ""
            End If
        Next
    End With

    'Remplissage de la colonne [G] (cortege)(Checkbox3)
    'Remplissage de la colonne [H] (autres_infos)(Checkbox4)
    'Remplissage de la colonne [I] (x)(Checkbox7)
    'Remplissage de la colonne [J] (y)(Checkbox8)
    'Remplissage de la colonne [K] (created_date)(Checkbox5)
    'Remplissage de la colonne [L] (created_user)(Checkbox6)
    With Worksheets("Correspondances")
        For i2 = 2 To lrco
            co.Cells(i2, 11).NumberFormat = "dd/mm/yyyy;@"
            co.Cells(i2, 10).NumberFormat = "General"
            co.Cells(i2, 2).NumberFormat = "@"
            Set re = plagebota.Find(.Cells(i2, 1), LookAt:=xlWhole)
            If Not re Is Nothing Then
                If UserForm13.CheckBox3 = True Then
                    co.Cells(1, 7).Value = fb.Cells(1, 5).Value
                    .Cells(i2, 7) = re.Offset(, 4) 'cortège
                End If
                If UserForm13.CheckBox4 = True Then
                    co.Cells(1, 8).Value = fb.Cells(1, 6).Value
                    .Cells(i2, 8) = re.Offset(, 5) 'autres infos
                End If
                If UserForm13.CheckBox7 = True Then
                    co.Cells(1, 11).Value = fb.Cells(1, 12).Value
                    .Cells(i2, 11) = re.Offset(, 6) 'x
                End If
                If UserForm13.CheckBox8 = True Then
                    co.Cells(1, 12).Value = fb.Cells(1, 13).Value
                    .Cells(i2, 12) = re.Offset(, 12) 'y
                End If
                If UserForm13.CheckBox5 = True Then
                    co.Cells(1, 9).Value = fb.Cells(1, 16).Value
                    .Cells(i2, 9) = re.Offset(, 15) 'created_date
                End If
                If UserForm13.CheckBox6 = True Then
                    co.Cells(1, 10).Value = fb.Cells(1, 17).Value
                    .Cells(i2, 10) = re.Offset(, 16) 'created_user
                End If
            Else
                    .Cells(i2, 7) = ""
                    .Cells(i2, 8) = ""
                    .Cells(i2, 11) = ""
                    .Cells(i2, 12) = ""
                    .Cells(i2, 9) = ""
                    .Cells(i2, 10) = ""
            End If
        Next
    End With

    co.Cells(1, 1).Value = sa.Cells(1, 6).Value
    co.Cells(1, 2).Value = fb.Cells(1, 4).Value
    co.Cells(1, 3).Value = sa.Cells(1, 3).Value
    Cells(1, 4).Value = "Correspondance"
    Cells(1, 13).Value = "Identifiant unique"

            'Retirer l'heure de la date
Dim Nc, Cib As Range
    For Each Cib In Range("K2:K" & lrco)
        Cib.Value = Trim(Cib.Value) 'supprime espaces
        Nc = Len(Cib)               'compte les caractères
            If Len(Cib.Value) > 10 Then Cib.Value = Left(Cib, Nc - 9)
    Next Cib
End Sub

DeleteBlankColumns (Long)

Public Sub DeleteBlankColumns()
Dim lastColumn As Long, lCol As Long
Set co = Worksheets("Correspondances")
    With co
        lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
        For lCol = lastColumn To 1 Step -1
            If Application.CountA(.Columns(lCol)) = 0 Then .Columns(lCol).EntireColumn.delete
        Next lCol
    End With
End Sub

structab (Rapide)

Sub structab()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With co
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Correspondances"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Correspondances"
        End If
    End With
End Sub

CorrCodes (Rapide)

Sub CorrCodes()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim lrco As Long

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
Dim supspa As Range

    For Each supspa In Sheets("Correspondances").Range("C1:C" & lrco)
        supspa.Value = Trim(supspa.Value) 'RTrim = suppr espace en fin de chaine ; LTrim en début de chaine
    Next supspa

    Columns("C:C").Replace what:="subsp.", Replacement:="ssp.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="subsp", Replacement:="ssp.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="sssp", Replacement:="ssp.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="var", Replacement:="var.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="varr", Replacement:="var.", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="..", Replacement:=".", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Columns("C:C").Replace what:="  ", Replacement:=" ", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

Dim i As Long, j As Long
Dim tbl As Variant, x As Variant
Dim arr() As String, txt As String

    With co
        tbl = .Cells(2, 3).Resize(lrco - 1)
    End With

    ReDim arr(1 To UBound(tbl), 1 To 1)
    For i = LBound(tbl) To UBound(tbl)
        txt = ""
        x = Split(Application.Trim(tbl(i, 1)))
        For j = LBound(x) To UBound(x)
            txt = txt & " " & Left(x(j), 4)
        Next j
        If Right(txt, 2) = "sp" Then txt = txt & "."
        arr(i, 1) = Application.Trim(txt)
    Next i
    co.Cells(2, 3).Resize(UBound(tbl), 1).Value = arr
End Sub

supprvide (Long)

Public Sub supprvide()
Dim co As Worksheet
Dim w As Integer, lrco As Integer

Set co = Worksheets("Correspondances")
lrco = co.Cells(Rows.Count, 1).End(xlUp).Row

For w = lrco To 1 Step -1
    If co.Cells(w, 3) = "" Then co.Rows(w).EntireRow.delete
Next w
End Sub

sumdel (Long)

Sub sumdel()

Dim x As Long

Application.EnableEvents = False
'Application.ScreenUpdating = False

For x = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Cells(x, 3) = Cells(x - 1, 3) And Cells(x, 2) = Cells(x - 1, 2) And Cells(x, 8) = Cells(x - 1, 8) Then
        Rows(x).delete Shift:=xlUp
    End If
Next

Application.EnableEvents = True
'Application.ScreenUpdating = True

CorrectAuto (Long)

Sub CorrectAuto()

Dim dic As Worksheet, co As Worksheet
Dim lrdic As Integer, lrco As Integer

Set dic = Worksheets("Bibliothèque")
Set co = Worksheets("Correspondances")

Application.ScreenUpdating = False
    Dim n As Integer
    Dim d() As String
    Dim t As Long, j As Long, p As Long

With dic
    lrdic = .Cells(.Rows.Count, 1).End(xlUp).Row ' compte le nombres de lignes utilisées dans table
    ReDim Preserve d(2, lrdic + 1) ' défini un tableau à 2 dimensions (2 , Nb de lignes)
        For p = 1 To lrdic
            d(1, p) = .Cells(p, 1).Value 'boucle qui charge dans le tableau les anciens codes et les nouveaux
            d(2, p) = .Cells(p, 2).Value
        Next p
End With

With co
lrco = .Cells(.Rows.Count, 1).End(xlUp).Row ' compte le nombre de lignes utilisées dans base

    For t = 1 To lrco ' boucle sur nombre de lignes de base
    For j = 1 To lrdic ' boucle sur nombre de lignes de table

    If d(1, j) = .Cells(t, 3).Value Then _
    .Cells(t, 3).Value = d(2, j) ' compare la valeur ancienne du tableau avec le contenu de la cellule colonne a de base
    Next j ' change la valeur si la comparaison est vrai
    Next t
    .Activate
End With
End Sub

corresp (Rapide)

Sub corresp()

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")
Set dc = Worksheets("Database complete")
Set ds = Worksheets("Database synonymes complete")

                'Compéter la nouvelle colonne "correspondances"
                Dim ii As Integer, vv As Variant
                    Set dc = Sheets("Database complete")
                    Set ds = Sheets("Database synonymes complete")
                    derLn = dc.Range("A" & Rows.Count).End(xlUp).Row
                    derLn2 = ds.Range("A" & Rows.Count).End(xlUp).Row

                    For ii = 2 To co.Range("A" & Rows.Count).End(xlUp).Row
                        nb = WorksheetFunction.CountIfs(dc.Range("A2:A" & derLn), co.Range("C" & ii))
                        nb2 = WorksheetFunction.CountIfs(ds.Range("B2:B" & derLn2), co.Range("C" & ii))
                        If nb = 0 Then
                            If nb2 > 0 Then
                                co.Range("D" & ii) = "Synonymes"
                            ElseIf nb2 = 0 Then
                            co.Range("D" & ii) = "Code erroné"
                            End If
                        ElseIf nb >= 2 Then
                            co.Range("D" & ii) = "Codes jumeaux"
                        ElseIf nb = 1 And nb < 2 And nb <> 0 Then
                            On Error Resume Next
                            vv = Application.WorksheetFunction.VLookup(co.Cells(ii, 3), Sheets("Database complete").Range("A:G"), 7, 0)
                            co.Cells(ii, 4) = IIf(IsError(vv), 0, vv)
                        End If
                    Next ii

                Unload UserForm4
                Unload UserForm13
End Sub

style (Rapide)

Sub style()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim lrco As Long

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    lrco = co.Cells(Rows.Count, 1).End(xlUp).Row

    Dim a As Integer

        For a = 2 To lrco
            If co.Cells(a, 4) = "Code erroné" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(204, 51, 0)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(255, 255, 255)
            Else
                If co.Cells(a, 4) = "Codes jumeaux" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(255, 255, 102)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                Else
                    If co.Cells(a, 4) = "Synonymes" Then
                    co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(71, 185, 182)
                    co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                    Else
                        If co.Cells(a, 4) <> "Synonymes" Or co.Cells(a, 4) <> "Code erroné" Or co.Cells(a, 4) <> "Codes jumeaux" Then
                        co.Range(Cells(a, 4), Cells(a, 4)).Interior.ColorIndex = xlColorIndexNone
                        co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                        End If
                    End If
                End If
            End If
        Next a

End Sub

RechErr (Rapide)

Sub RechErr()

Set co = Worksheets("Correspondances")
lrco = co.Cells(Rows.Count, 1).End(xlUp).Row

    Dim Plageb As Range
    Dim Cibleb, Cible2b, Cible3b
    Set Plageb = co.Range("D1:D" & lrco)
    On Error Resume Next
    Cibleb = Application.WorksheetFunction.CountIf(Plageb, "=Code erroné")
    Cible2b = Application.WorksheetFunction.CountIf(Plageb, "=Codes jumeaux")
    Cible3b = Application.WorksheetFunction.CountIf(Plageb, "=Synonymes")
    If Cibleb + Cible2b + Cible3b > 0 Then UserForm3.Show 'UserForm3.Show

End Sub

Par ailleurs, sur différentes feuilles, j'ai des UserForms que j'ouvre en modal. Lorsque je passe sur une autre feuille je les ferme en utilisant ces lignes :

Private Sub Worksheet_Activate()

If UserForm4.Visible Then Unload UserForm4
If UserForm7.Visible Then Unload UserForm7
If UserForm8.Visible Then Unload UserForm8
If UserForm9.Visible Then Unload UserForm9
If UserForm10.Visible Then Unload UserForm10
If UserForm11.Visible Then Unload UserForm11
If UserForm13.Visible Then Unload UserForm13
End if

Il me semble que ça relançe le chargement du tous les Userforms pour les décharger ensuite. C'est étrange. Est-ce que c'est la bonne méthode ?

Ce sont les boucles qui engendrent le plus de ralentissements ; est-ce que vous sauriez m'expliquer comment me passer de celles qui sont inutiles ? Vue la longueur du code c'est normal que vous ne procédiez pas aux changements, mais le problème c'est que je ne sais pas comment m'y prendre, alors éventuellement avec un exemple ?

Actuellement, pour 6 lignes d'un tableau, Excel met 12 secondes à effectuer tous les traitements.

Sachant que je peux aller facilement jusqu'à 400 lignes (1000+ dans de très rares cas), ça pourrait prendre beaucoup de temps.

(Heureusement, ça ne prend pas 2 secondes par lignes, contrairement à ce que pourrait laisser croire l'exemple ; pour 300 lignes Excel prend 1 min 20).

Je vous remercie de votre attention !

En espérant que vous ayez encore quelques corrections à me proposer pour optimiser tout ça

Puisque tout est fait, je vais continuer à chercher en ce qui concerne les boucles..

Bonne journée !

Bonsoir,

Comme cela me l'a été conseillé, je propose un document d'exemple en téléchargement si cela peut donner une meilleure idée de la manière dont s'exécute le code.

Pour une raison que j'ignore, après avoir un peu nettoyé le code je n'ai plus les mêmes temps d'exécution (27secondes au lieu d'1min 32 parfois).

Il risque d'y avoir beaucoup plus de données à terme, alors je reste très demandeur si vous avez des solutions pour éviter l'utilisation systématique des boucles.

Le lien vers le document.

https://cjoint.com/c/IGkqmOkFv5h

Je vous remercie de votre attention. Et de l'aide que vous m'avez déjà apporté !

Bonne fin de journée.

Salut Le Drosophile

Pour éviter des boucles, tu peux utiliser des filtres, par exemple petite modification

  'Conserver les valeurs recherchées (num étude)
  With Co
    ' #ORIGINAL
    'For del = Co.Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
      'If .Range("B" & del).Value <> n Then
        '.Rows(del).Delete
      'End If
    'Next del
    '#REMPLACE PAR
    lrco = .Range("A" & Rows.Count).End(xlUp).Row
    .Rows(1).AutoFilter
    .Rows("1:" & lrco).AutoFilter Field:=2, Criteria1:="<>" & n, Operator:=xlAnd
    .Rows("2:" & lrco).Delete Shift:=xlUp
    .ShowAllData
  End With

En revanche à partir du moment ou ta plage est transformée en objet tableau, ce n'est plus la même histoire

A+

Bonjour,

La proposition que vous avez faite supprime toutes les lignes en ne conservant qu'une seule ligne correspondant à la variable n.

A l'origine, le code conserve toutes les lignes dont la colonne B contient la variable n.

Est-ce que c'est ce que vous vouliez faire ?

EDIT : En réalité, ce problème vient de ce code :

co.Range(Cells(2, 1), Cells(lrco, lcco)).RemoveDuplicates Columns:=Array(4)

Je ne comprend pas pourquoi, il supprime toutes les lignes pour n'en garder qu'une...

Voilà tout est bon, j'exécutais le code à un moment où la colonne était vide...

Merci de votre proposition, il faut que je teste pour voir s'il y a un gain de temps ou pas !

Bonjour,

Après avoir modifié les codes suivants :

Sumdel (ancien)

Sub sumdel()

Dim x As Long

Application.EnableEvents = False
'Application.ScreenUpdating = False

For x = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Cells(x, 3) = Cells(x - 1, 3) And Cells(x, 2) = Cells(x - 1, 2) And Cells(x, 8) = Cells(x - 1, 8) Then
        Rows(x).delete Shift:=xlUp
    End If
Next

Application.EnableEvents = True
'Application.ScreenUpdating = True

Sumdel (nouveau)

Sub sumdel01()

    lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
    lcco = co.Cells(1, co.Columns.Count).End(xlToLeft).Column

co.Range(Cells(2, 1), Cells(lrco, lcco)).RemoveDuplicates Columns:=Array(3)

End Sub

Ancien

   With co
        For del = co.Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If .Range("B" & del).Value <> n Then
                .Rows(del).delete
            End If
        Next del
    End With

Nouveau

    With co
    lrco = .Range("A" & Rows.Count).End(xlUp).Row
        .Rows(1).AutoFilter
        .Rows("1:" & lrco).AutoFilter Field:=2, Criteria1:="<>" & n, Operator:=xlAnd
        .Rows("2:" & lrco).delete Shift:=xlUp
        .ShowAllData
    End With

J'ai un temps d'exécution qui atteint 26 secondes.

En comparaison avec mon ancien test, c'est pas immense haha !

Celui-ci prend encore 6 secondes :

CorrectAuto

Sub CorrectAuto()

Dim dic As Worksheet, co As Worksheet
Dim lrdic As Integer, lrco As Integer

Set dic = Worksheets("Bibliothèque")
Set co = Worksheets("Correspondances")

Application.ScreenUpdating = False
    Dim n As Integer
    Dim d() As String
    Dim t As Long, j As Long, p As Long

With dic
    lrdic = .Cells(.Rows.Count, 1).End(xlUp).Row ' compte le nombres de lignes utilisées dans table
    ReDim Preserve d(2, lrdic + 1) ' défini un tableau à 2 dimensions (2 , Nb de lignes)
        For p = 1 To lrdic
            d(1, p) = .Cells(p, 1).Value 'boucle qui charge dans le tableau les anciens codes et les nouveaux
            d(2, p) = .Cells(p, 2).Value
        Next p
End With

With co
lrco = .Cells(.Rows.Count, 1).End(xlUp).Row ' compte le nombre de lignes utilisées dans base

    For t = 1 To lrco ' boucle sur nombre de lignes de base
    For j = 1 To lrdic ' boucle sur nombre de lignes de table

    If d(1, j) = .Cells(t, 3).Value Then _
    .Cells(t, 3).Value = d(2, j) ' compare la valeur ancienne du tableau avec le contenu de la cellule colonne a de base
    Next j ' change la valeur si la comparaison est vrai
    Next t
    .Activate
End With
End Sub

Mais celui-ci, le plus gourmand prend 15 secondes, pourtant lors des premiers tests, il ne me semblais pas qu'il prenait tant de temps :

structab

Sub structab()
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With co
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Correspondances"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Correspondances"
        End If
    End With
End Sub

Comme on me l'a fait remarquer, pensez-vous que ça puisse simplement venir du fait que j'utilise "Correspondances" pour désigner plusieurs choses dans tout le document ? (Feuille, tableau, liste, etc.)

Bonne journée !

Bonsoir,

Je n'ai rien trouvé pour accélérer l'exécution de ce code pour le moment :/

Rechercher des sujets similaires à "vba vitesse execution code"