Simplification de macro lourde

Bonjour,

J'ai une macro assez longue et répétitive, et j'aimerais savoir s'il y a un moyen de raccourcir la macro tout en gardant sa fonctionnalité.

Ma macro :

Sub Bouton3_Cliquer()

For Each cel In ActiveSheet.Range("D1:D" & Range("D" & Rows.Count).End(xlUp).Row)

''''' recopie des consignes'''''''''

If cel Like "*consigne*" Or cel Like "*Consigne*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Consigne"

End If

''''' recopie des "taux"'''''''''

If cel Like "*taux*" Or cel Like "*Taux*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Taux"

End If

''''' recopie des debits''''''

If cel Like "*debit*" Or cel Like "*Debit*" Or cel Like "*débit*" Or cel Like "*Débit*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Débit"

End If

''''' recopie des cadences '''''

If cel Like "*cadence*" Or cel Like "*Cadence*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Cadence"

End If

''''' recopie des tempo '''''

If cel Like "*temporisation*" Or cel Like "*Temporisation*" Or cel Like "*tempo*" Or cel Like "*Tempo*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Temporisation"

End If

''''' recopie des fréquences '''''

If cel Like "*frequence*" Or cel Like "*fréquence*" Or cel Like "*Frequence*" Or cel Like "*Fréquence*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Fréquence"

End If

''''' recopie des temps '''''

If cel Like "*temps*" Or cel Like "*Temps*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Temps"

End If

''''' recopie des durees '''''

If cel Like "*duree*" Or cel Like "*durée*" Or cel Like "*Duree*" Or cel Like "*Durée*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Durée"

End If

''''' recopie heures '''''

If cel Like "*Heure*" Or cel Like "*heure*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Heure"

End If

''''' recopie minutes '''''

If cel Like "*Minute*" Or cel Like "*minute*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Minute"

End If

''''' recopie nombre '''''

If cel Like "*Nombre*" Or cel Like "*nombre*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Nombre"

End If

''''' recopie concentrations'''''

If cel Like "*Concentration*" Or cel Like "*concentration*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Concentration"

End If

''''' recopie plages'''''

If cel Like "*debut plage*" Or cel Like "*début plage*" Or cel Like "*Début plage*" Or cel Like "*Debut plage*" Then

'copie le terme à la colonne 4 à droite de la colonne D

cel.Offset(0, 4) = "Plage"

End If

Next cel

End Sub

Bonjour FGR, bonjour le forum,

Essaie comme ça :

Sub Bouton3_Cliquer()
Dim TM As Variant 'déclare la variable TM (Tableau des Mots)
Dim TC As Variant 'déclare la variable TC (Tableau des Correspondances)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)

'définit le tablau des mots TM
TM = Array("consigne", "taux", "bit", "cadence", "tempo", "quence", "temps", "dur", "heure", "minute", "nombre", "concentration", "but plage")
'définit le tablau des correspondances TC
TC = Array("Consigne", "Taux", "Débit", "Cadence", "Temporisation", "Fréquence", "Temps", "Durée", "Heure", "Minute", "Nombre", "Concentration", "Plage")
'définit la plage PL
Set PL = ActiveSheet.Range("D1:D" & Range("D" & Rows.Count).End(xlUp).Row)
For Each CEL In PL ' boucle 1 : sur toutes les cellule CEL de la palge PL
    For I = 0 To UBound(TM) 'boucle 2 : sur tous les mots du tableau des mots TM
        'si le mot du tableau est contenu dans la cellule CEL, renvoie dans la colonne H le mot correspondant tu tableau des correspondances, sort de la boucle 2
        If InStr(1, CEL.Value, TM(I), vbTextCompare) <> 0 Then CEL.Offset(0, 4).Value = TC(I): Exit For
    Next I 'prochain mot de la boucle 2
Next CEL 'prochaine cellule de la boucle 1
End Sub

Salut Thauthème,

Je te remercie pour ton aide, ta macro marche très bien.

Et merci pour la rapidité avec laquelle tu as répondu.

Cordialement.

FGR

Rechercher des sujets similaires à "simplification macro lourde"