passer d'une exécution automatique à un bouton macro

Version imprimable

Bonjour à tous,

J'aimerai transformé le code ci-dessous en macro pour ensuite l'ajouter dans un module VBA qui permettra de créer un bouton pour exécuter ce code.

Ce code permet de convertir de manière automatique les lettres minuscules en majuscules sans accent dans une feuille active.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 Sub Worksheet_Change(ByVal Target As Range) If Not Application.Intersect(Target, Range("c6:s5000")) Is Nothing Then codeA = "ÉÈÊËÔéèêëàçùôûïî" codeB = "EEEEOeeeeacuouii" temp = Target For i = 1 To Len(temp) p = InStr(codeA, Mid(temp, i, 1)) If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1) Next Application.EnableEvents = False Target = UCase(temp) Application.EnableEvents = True End If End Sub
Merci pour votre aide !

Bonjour,
Je ne sais pas si c'est ce que tu cherches mais voici un code qui parcourt les cellules de C6 à S5000 de la feuille active et qui exécute le même code que celui que tu avais placé dans la procédure événementielle de la feuille.
S'il n'y a plus de procédure événementielle sur la feuille traitée il n'y a plus lieu évidemment de laisser les deux lignes de code Application.EnableEvents
Philippe Tulliez
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Sub WorksheetChange() Application.ScreenUpdating = False Dim cellule As Range, cel As Range Set cellule = Range("c6:s5000") ' A modifier éventuellement codeA = "ÉÈÊËÔéèêëàçùôûïî" codeB = "EEEEOeeeeacuouii" For Each cel In cellule If Not (IsEmpty(cellule)) Then temp = cel For i = 1 To Len(temp) p = InStr(codeA, Mid(temp, i, 1)) If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1) Next Application.EnableEvents = False cel = UCase(temp) Application.EnableEvents = True End If Next Application.ScreenUpdating = False End Sub

23/12/2010, 17h31
titou8333

Merci beaucoup Philippe !

La lancement de cette macro sur mon PC prend effectivement beaucoup de temps.
Serait-il possible d'ajouter une barre de progression de la macro ?

J'ai essayé d'utiliser le code issu du site de microsoft mais je n'ai pas réussi à l'adapter.
http://support.microsoft.com/kb/211736/fr

Aurais-tu une idée ?

Merci encore

Bonsoir,
Désolé mais je me suis trompé dans une ligne ce qui explique la lenteur de l'exécution.
Dans la ligne où j'indique 'Erreur ici' j'avais utilisé la variable objet cellule au lieu de cel.
Cela devrait aller maintenant très vite.
Pour accélérer le code, tu peux aussi couper le calcul automatique avec Application.Calculation comme montré dans l'exemple.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
Sub WorksheetChange()
  With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationManual
  End With
  Dim cellule As Range, cel As Range
  Set cellule = Range("c6:s5000") ' A modifier éventuellement
  codeA = "ÉÈÊËÔéèêëàçùôûïî": codeB = "EEEEOeeeeacuouii"
  For Each cel In cellule
    If Not (IsEmpty(cel)) Then  ' <<< Erreur ici <<<<
    temp = cel
    For i = 1 To Len(temp)
    p = InStr(codeA, Mid(temp, i, 1))
    If p > 0 Then Mid(temp, i, 1) = Mid(codeB, p, 1)
  Next
  Application.EnableEvents = False
  cel = UCase(temp)
  Application.EnableEvents = True
  End If
  Next
  With Application
  .ScreenUpdating = False
  .Calculation = xlCalculationAutomatic
  End With
End Sub

Tu peux encore gagner en vitesse en utilisant l'instruction REPLACE comme ci-dessous.

Code:

1
2
3
4
5
 
For i = 1 To Len(temp)
   p = InStr(codeA, Mid(temp, i, 1))
   If p Then temp = Replace(temp, Mid(temp, i, 1), Mid(codeB, p, 1))
Next

23/12/2010, 18h52
titou8333

Merci Philippe !

Bonne soirée

Brice

Pour ne pas tester toutes les cellules

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Tst()
Dim Cel As Range
Dim i As Integer, p As Integer
Const codeA As String = "ÉÈÊËÔéèêëàçùôûïî"
Const codeB As String = "EEEEOeeeeacuouii"
 
With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationManual
End With
With Sheets("Feuil1")
     On Error GoTo Erreur
     For Each Cel In Range("c6:s5000").SpecialCells(xlCellTypeConstants)
          For i = 1 To Len(Cel.Value)
               p = InStr(codeA, Mid(Cel.Value, i, 1))
               If p > 0 Then Cel.Value = Replace(Cel.Value, Mid(Cel.Value, i, 1), Mid(codeB, p, 1))
          Next i
          Cel.Value = UCase(Cel.Value)
     Next Cel
End With
Erreur:
With Application
     .ScreenUpdating = False
     .Calculation = xlCalculationAutomatic
End With
End Sub

24/12/2010, 12h03
titou8333

Merci à vous 2.