bonjour Foruma , bonjour Jean-Marie
tu peux tester cette macro
rappel important :
il ne faut pas déprotéger les documents qui ne sont pas votre propriété !
Dim Chaine As Integer
Dim Suite As String, LettresCle As String
Dim Char() As String
Dim Status As Byte
Sub RechercherSuiteDeCaracteres()
'procédure de aKheNathOn
'http://www.vbfrance.com/article.aspx?ID=5201
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'adapté par MichelXld le 18.08.2004
Dim i As Byte
Dim Caract As Byte
Dim ErrNum As Integer
'***************************************************************************************
'adapter la variable "LesttresCle" pour définir la liste des caracteres à utiliser
'=======================================================================================
LettresCle = "0123456789azertyuiopqsdfghjklmwxcvbnAZERTYUIOPQSDFGHJKLMWXCVBN!@#$%^&*()+="
'LettresCle = "0123456789"
'LettresCle = "azertyuiopqsdfghjklmwxcvbn" ' ordre clavier
'LettresCle = "abcdefghijklmnopqrstuvwxyz"
'LettresCle = "easitnrulodcmpvqgfbhjxyzwk" 'Ordre d'apparition statistitique alphabet français
'Ordre d'apparition statistitique de l'alphabet français:
'pour cette derniere option il serait interessant de faire des tests , par exemple , sans
'utiliser les 5 derniers caracteres de la variable "LettresCles" (probabilité d'apparition
'faible pour une recherche d'un mot du dictionnaire )
'Cela n'est evidemment pas valable s'il s'agit d'un mot d'une langue étrangère
'***************************************************************************************
Application.DisplayStatusBar = True
Status = 1
LettresCle = LettresCle & "#"
If Len(Range("A1")) < Range("A3") Then
MsgBox "La valeur de la Cellule A3 ne peut etre inférieure au nombre " & _
"de caracteres de la cellule A1 .", , "Message"
Exit Sub
End If
Chaine = 1 ' nombre de caracteres pour débuter
ReDim Char(Chaine - 1) As String
For i = 0 To Chaine - 1
Char(i) = Left(LettresCle, 1)
Next i
Do
ErrNum = 0
On Error Resume Next
'adapter le nom de la feuille à ouvrir
ActiveSheet.Unprotect Password:=Change_Suite
ErrNum = Err.Number
If ErrNum = 0 Then
MsgBox "La feuille est déprotégée ." & Chr(10) & _
"N'oubliez pas d'enregistrer les modifications avant de quitter le classseur .", , "Message"
Application.DisplayStatusBar = False
Exit Sub
End If
DoEvents
Loop
End Sub
Function Change_Suite() As String
Dim i As Integer
If Status = 1 Then
Status = 2
Else
Char(0) = Mid(LettresCle, InStr(1, LettresCle, Char(0)) + 1, 1)
End If
For i = 0 To Chaine - 1
If Char(i) = Right(LettresCle, 1) Then
If Chaine - 1 = i Then
ReDim Preserve Char(Chaine + 1)
Chaine = Chaine + 1
Char(i) = Left(LettresCle, 1)
Char(i + 1) = Left(LettresCle, 1)
Else
Char(i) = Left(LettresCle, 1)
Char(i + 1) = Mid(LettresCle, InStr(1, LettresCle, Char(i + 1)) + 1, 1)
End If
End If
Next i
Suite = ""
For i = Chaine - 1 To 0 Step -1
Suite = Suite & Char(i)
Next i
Change_Suite = Suite
'********************************
Application.StatusBar = Suite
'********************************
End Function
bonne soirée
MichelXld
