[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 :/