Discussion :

[titou8333]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 !

[Philippe Tulliez]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[Philippe Tulliez]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[titou8333]

Merci Philippe !

Bonne soirée

Brice

[mercatog]

Pour ne pas tester toutes les cellules

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[titou8333]

Merci à vous 2.