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

Y compris Power BI, Power Query et toute autre question en lien avec Excel
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 22 juin 2019, 17:33

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 :
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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
SpoilerAfficher
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 !
j
jvdo
Jeune membre
Jeune membre
Messages : 42
Appréciation reçue : 1
Inscrit le : 25 juillet 2018
Version d'Excel : 2010

Message par jvdo » 22 juin 2019, 17:44

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
Avatar du membre
galopin01
Passionné d'Excel
Passionné d'Excel
Messages : 6'082
Appréciations reçues : 114
Inscrit le : 18 septembre 2008
Version d'Excel : 2016
Téléchargements : Mes applications

Message par galopin01 » 22 juin 2019, 18:23

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+
Ici c'est un forum Excel/VBA pas Photoshop :
Quand vous amenez votre voiture au garagiste vous lui donnez pas juste la photo ?
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 22 juin 2019, 18:34

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.
Avatar du membre
BrunoM45
Membre impliqué
Membre impliqué
Messages : 2'890
Appréciations reçues : 87
Inscrit le : 29 octobre 2011
Version d'Excel : 2016 FR, O365 FR
Contact :

Message par BrunoM45 » 22 juin 2019, 18:44

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+
Modifié en dernier par BrunoM45 le 22 juin 2019, 18:51, modifié 1 fois.
1 membre du forum aime ce message.
[F1] est une touche qui appelle l'aide : Essayez, c'est assez performant et on trouve plein de choses

Il n'y a ni bon ni mauvais usage de la liberté d'expression, il n'en existe qu'un usage insuffisant.
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 22 juin 2019, 18:48

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.
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 7 juillet 2019, 16:11

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)
SpoilerAfficher
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.
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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)
SpoilerAfficher
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 :
SpoilerAfficher
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 ? :D


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 !
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 10 juillet 2019, 18:17

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.
Avatar du membre
BrunoM45
Membre impliqué
Membre impliqué
Messages : 2'890
Appréciations reçues : 87
Inscrit le : 29 octobre 2011
Version d'Excel : 2016 FR, O365 FR
Contact :

Message par BrunoM45 » 11 juillet 2019, 02:10

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 :bof:

A+
1 membre du forum aime ce message.
[F1] est une touche qui appelle l'aide : Essayez, c'est assez performant et on trouve plein de choses

Il n'y a ni bon ni mauvais usage de la liberté d'expression, il n'en existe qu'un usage insuffisant.
L
Le Drosophile
Membre fidèle
Membre fidèle
Messages : 323
Appréciation reçue : 1
Inscrit le : 27 juin 2018
Version d'Excel : 2016

Message par Le Drosophile » 13 juillet 2019, 12:00

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 !
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message