Fonctions sur les chaînes

Accueil

Len(chaîne)
Left(chaîne,nb_caractères à gauche)
Right(chaîne,nb caractères à droite)
Mid(chaîne,début,longueur)
Ucase(chaîne)
Lcase(chaîne)
Instr(début,chaîne,chaîne cherchée)
InstrRev(début,chaîne,chaîne cherchée)
Replace(chaîne,chaîneARemplacer,NouvelleChaine)
Opérateur Like
RegExp
Coloriage de caractères

Len(chaîne)

Donne le nombre de caractères d'une chaîne de caractères.

x="Dupont"
MsgBox Len(x,3)

Résultat
6

Left(chaîne, nombre_caractères à gauche)

Donne le nombre de caractères à gauche d'une chaîne.

x="Dupont"
MsgBox Left(x,3)

Résultat
Dup

Right(chaîne, nombre_caractères à gauche)

Donne le nombre de caractères à droite d'une chaîne.

x="Dupont"
Msgbox Right(x,4)

Résultat
Pont

Mid(chaîne, position, nombre à prendre)

Donne le nombre de caractères spécifiés à partir de la position spécifiée.

x="Dupont"
Msgbox Mid(x,3,2)

Résultat
po

Si nombre à prendre n'est pas spécifié, on obtient tous les carcatères à droite.

Mid(VariableChaîne,position,nbcaractèresAremplacer)=expression

Remplace des caractères à partir de la position spécifiée.

x="Dupont"
Mid(x,4,2)="xx"
Msgbox x

Résultat
Dupxxt

Ucase(chaîne)

Convertit une chaîne en majuscules.

Ci dessous, le programme inverse la casse des cellules sélectionnées.

Sub inverseCasse()
  For Each c In Selection
    temp = ""
    For i = 1 To Len(c)
      temp = temp & IIf(Asc(Mid(c, i, 1)) >= 96, UCase(Mid(c, i, 1)), LCase(Mid(c, i, 1)))
    Next i
    c.Value = temp
  Next c
End Sub

Lcase(chaîne)

Convertit une chaîne en minuscules.

Instr(début,chaîne,chaîne_cherchée)

Donne la position d’une chaîne dans une autre.

Msgbox Instr("Dupont Jean"," ")

Résultat
7

InstrRev(début,chaîne,chaîne_cherchée)

Donne la position d’une chaîne dans une autre en partant de la droite(à partir de 2000).

Msgbox InstrRev("aaa*bbbb*ccc","*")

Résultat
9

En A1:A5, on a

c:/Rep1/Srep1/toto.xls
D:/Rep2/titi.txt
C:/Rep1/srep2/tata.doc
C:/Rep1/Srep2/Ssrep3/Sssrep4/Tutu.pdf
E:/Rep1/Srep2/Ssrep3/Sssrep4/Ssssrep5/Tete.csv

On veut en colonne B

toto.xls
titi.txt
tata.doc
Tutu.pdf
Tete.csv

For Each c In Range([A1], [A65000].End(xlUp))
  c.Offset(, 1) = Mid(c, InStrRev(c, "/") + 1)
Next c

Pour copier les fichiers dans c:/temp

For Each c In Range([A1], [A65000].End(xlUp))
  FileCopy c, "c:/temp/" & Mid(c, InStrRev(c, "/") + 1)
Next c

Avec une formule matricielle

=DROITE(A1;EQUIV("/";STXT(A1;NBCAR(A1)-LIGNE($1:$255);1);0))
Valider avec maj+ctrl+entrée

Replace(chaine, chaîneAmodifier,nouvelleChaîne)

Remplace des caractères dans une chaîne de caractères.

For Each c In Selection
  c.Value = Replace(c.Value, ".", ",")
Next c

Opérateur Like

résultat = chaîne Like modèle

Caractères) dans Modèle

Correspondance dans l'argument chaîne

?

Tout caractère unique.

*

Aucun ou plusieurs caractères.

#

Tout chiffre unique (de 0 à 9).

[ensemble] Spécifie un ensemble

result = "Dupont" Like "*po*"                                        ' donne True
result = "Dupont" Like "*xx*"                                        ' donne False
result = "4,rue Nobel 78180 Montigny" Like "*#####*"  ' donne True
result = "K" Like "[A-Z]"                                               ' donne True
result = "K" Like "[a-z]"                                                ' donne False
result = "DUPONT" Like "DUPON?"                                 ' donne True
result = "xxBn" Like "xx[A-M][!c-e]"                              ' donne True
result = "kkkk/bbbbb" Like "*[+-/~*]*"                         ' donne True
result = "AZE75" Like "[A-Z][A-Z][A-Z][0-9][0-9]"          ' donne True

Sur cet exemple, on veut découper sur 2 lignes. On recherche la position du code postal:

12, rue lepic - Apt#55 - 75000 Paris sur Seine

Résultat :

12, rue lepic - Apt#55
75000 PARIS SUR SEINE

Sub essai3()
   chaine = Application.Trim([A1])
   p = 1
   témoin = False
   Do While p <= Len(chaine) - 4 And Not témoin
     If Mid(chaine, p, 5) Like "#####" Then témoin = True Else p = p + 1
   Loop
   If témoin Then
     Mid(chaine, p + 6) = UCase(Mid(chaine, p + 6))
     chaine = Left(chaine, p - 4) & Application.Substitute(Mid(chaine, p - 3), " - ", Chr(10))
     [B1] = chaine
   End If
End Sub

Ces fonctions retournent le code postal,la rue, la ville d’une chaîne contenant un code postal :

38 rue de la paix 12350 machin les roses

Function CodePostal(chaine)
  p = 1
  CodePostal = ""
  Do While p <= Len(chaine) - 4 And CodePostal = ""
    If Mid(chaine, p, 5) Like "#####" Then CodePostal = Mid(chaine, p, 5) Else p = p + 1
  Loop
End Function

Function Rue(chaine)
  p = 1
  Do While p <= Len(chaine) - 4 And Rue = ""
    If Mid(chaine, p, 5) Like "#####" Then Rue = Left(chaine, p - 2) Else p = p + 1
  Loop
End

Function Function Ville(chaine)
   p = 1
   Do While p <= Len(chaine) - 4 And Ville = ""
      If Mid(chaine, p, 5) Like "#####" Then Ville = Mid(chaine, p + 6) Else p = p + 1
  Loop
End Function

Extraire des numéros de téléphone

Blabla bla , et encore bla du 03/11/2011 bla bla téléphone= 05 55 45 78 89 et apres blabla mon tel est le
04.36.89.78.88 et encore 123bla bla bla T: 06,54,98,69,78 et encore bla bla bla48 et encore bla bla bla
tel:03/45/73/45/65 et encore bla bla bbla bla bla le telephone suivant 04;91;85;79;63 et encore bla bla bla 02\55\98\36\73

ExtraireTph

Sub essai()
  For Each c In [A1:A3]
    chaine = c & " "
    i = 1
    Do
      p = 1
      témoin = False
      Do While p <= Len(chaine) - 14 And Not témoin
        If Mid(chaine, p, 14) Like "##?##?##?##?##" Then témoin = True Else p = p + 1
      Loop
      If témoin Then
         temp = Mid(chaine, p, 14)
         For Each k In Array(".", ",", "/", ";", "\")
           temp = Replace(temp, k, " ")
         Next k
         c.Offset(, i) = temp
      End If
      chaine = Mid(chaine, p + 14)
      i = i + 1
    Loop While témoin
  Next c
End Sub

RegExp

^xxx

chaîne qui commence par xxx

xxx$

chaîne qui se termine par xxx

xyz

chaîne contenant la chaîne xyz

xyz+

* zero ou plusieurs       + un ou plusieurs       ? un ou aucun
Chaîne qui contient xy suivie de un ou plusieurs z (au moins un)

xyz*

Chaîne qui contient xy suivie de 0 ou plusieurs z (0 ou plusieurs)

xyz?

Chaîne qui contient xy suivie d'un z ou aucun (un ou aucun)

^xyz+

Chaîne commençant par xy suivie de un ou plusieurs z

xyz{2}

Chaîne qui contient xy suivie de deux z

xyz{2,}

Chaîne qui contient xy suivie de deux z ou plusieurs

xyz{2,4}

Chaîne qui contient xy suivie de 2 à 4 z

aaa|bbb

La barre verticale | spécifie OU. Chaîne qui contient aaa ou bbb"

[xyz]

Chaîne qui contient un x, y ou z

[a-z]

chaîne qui contient un caractère compris entre "a" et "z"

^[a-zA-Z]

chaîne qui commence par une lettre

[^a-z]

Caractère non compris entre a et z.

\w

un caractère lettre ou chiffre ou _; équivaut à [0-9a-zA-Z_]

\s

un caractère espace ; équivaut à[ \t\n\r\f]

\d

Equivaut à [0-9]

(?!xxx)

Assertion négative: ((?!Rue)[A-Z][a-z]+\s*)+
On extrait ce qui commence par une majuscule suivi de minuscules sauf Rue
Rue xxxxx Alfred Nobel -->Alfred Nobel

http://www.vbfrance.com/tutoriaux/EXPRESSIONS-RATIONNELLES-REGULIERES_520.aspx

Fonctions Extraire le nom et le prénom

RegExpNomPrénomAdresse

Function Nom(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "([A-Z'ÔË]{2,}\s*-?)+"
  Set a = obj.Execute(c)
  If a.Count > 0 Then Nom = a(0) Else Nom = ""
End Function

Function Prénom(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  c = Replace(Replace(Replace(c, "M.", ""), "Mme", ""), "Mle", "")
  obj.Pattern = "([A-Z][a-zëéèô]+\s*-?)+"
  Set a = obj.Execute(c)
  If a.Count > 0 Then Prénom = a(0) Else Prénom = ""
End Function

Function civilité(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "(Mme|M\.|Mle)\s"
  Set a = obj.Execute(c)
  If a.Count > 0 Then civilité = a(0) Else civilité = ""
End Function

Fonctions découpage adresse

28 rue du grand Faubourg 33015 La Rochelle

Function Rue(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "(\d{0,4}[\s,]?[a-z,A-Z]+\s)+"
  Set a = obj.Execute(c)
  If a.Count > 0 Then Rue = a(0) Else Rue = ""
End Function

Function Ville(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "\d{5}\s([A-Z,a-z,\s,-]+)"
  Set a = obj.Execute(c)
  If a.Count > 0 Then Ville = a(0).Submatches(0) Else Ville = ""
End Function

Function CodePostal(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "\d{5}"
  Set a = obj.Execute(c)
  If a.Count > 0 Then CodePostal = a(0) Else CodePostal = ""
End Function

Recherche de code postal dans un champ

Function CodePostal(champ As Range)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "\d{5}"
  For Each c In champ
    Set a = obj.Execute(c)
    If a.Count > 0 Then CodePostal = a(0): Exit Function
  Next c
  CodePostal = ""
End Function

Sub essai()
  tmp = CodePostal(Range("a1:a4"))
  MsgBox tmp
End Sub

Extraction d'un téléphone

RegExp

Function Tph(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "\d{2}[-/ ]\d{2}[-/ ]\d{2}[-/ ]\d{2}[-/ ]\d{2}"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Tph = a(0) Else Tph = ""
End Function

S'il y a plusieurs nos de tph

RegExpTph

Function Tph(chaine, n)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d{2}[-/. ]*\d{2}[-/. ]*\d{2}[-/. ]*\d{2}[-/. ]*\d{2}"
  Set a = obj.Execute(chaine)
  If a.Count > n - 1 Then Tph = a(n - 1) Else Tph = ""
End Function

Extraction email

Function Email(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "([\w\.\-])+@([\w\.\-])+"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Email = a(0) Else Email = ""
End Function

Extraction numérique et texte

Function Num(chaine, n)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function

Function Txt(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "[a-z,A-Z]+"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Txt = a(0) Else Txt = ""
End Function

Function DernierNum(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then DernierNum = Val(a(a.Count - 1)) Else DernierNum = 0
End Function

Extraction immatriculation

Function Immatric(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "(\d{1,4}[- ][A-Z]{2,3}[- ]\d{2})|([A-Z]{2}[- ][1-9]\d{2}[- ][A-Z]{2})"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Immatric = a(0) Else Immatric = ""
End Function

Extraction date

Function Dte1(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "\d{1,2}[-/ ]\d{1,2}[-/ ]\d{1,2}"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Dte1 = a(0) Else Dte1 = ""
End Function

Suppression de numérique dans une chaîne

Sub SupNumChaine()
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+"
  chaine = "xxx123yyy12"
  chaine = obj.Replace(chaine, "")
  MsgBox chaine
End Sub

Suppression de texte dans une chaîne

Sub SupTexteChaine()
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "[a-z,A-Z]+"
  chaine = "ABC123cde12"
  chaine = obj.Replace(chaine, "")
  MsgBox chaine
End Sub

Suppression de numérique

A partir de la chaîne:

Paris: 3.30 voie 4 - Orléans: 4.07 voie 1 - Angoulème : 6.20 voie 1

On veut obtenir: Paris-Orléans-Angoulème

Function SupTexte(c)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "[0-9,:.\s]|voie"
  SupTexte = obj.Replace(c, "")
End Function

Evalue une chaîne alphanumérique

porte 80*2

160

porte 1,80*2,0

3,6

La porte 1.80*2.1

3,78

La porte 1.80*2

3,6

La porte 1.80/3

0,6

La porte 1.80/4+6*6 Euros

36,45

La porte 1.80/4+6*6 $

36,45

80*2

160

RegExp9

Function calcul(chaine)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "[a-zA-Z\s\$]*"
  'obj.Pattern = "[^\d.,*/+-]*" 'David84
  calcul = Evaluate(obj.Replace(Replace(chaine, ",", "."), ""))
End Function

Fonction TransformeRue

Transforme l'écriture de l'adresse (permet un tri par rue)

Avant

Après

24,rue du Général De Gaulle

Général De Gaulle(24,rue du)

12 avenue d'Alésia

Alésia(12 avenue d')

sentier du Four

Four(sentier du)

Function RueTransforme(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "([A-Z][a-zëéèô]+\s*-?)+"
  Set a = obj.Execute(c)
  obj.Pattern = "((\d{0,4}[\s,]?[a-z]+)\s[a-z']+)+"
  Set b = obj.Execute(c)
  If a.Count > 0 Then RueTransforme = a(0) & "(" & b(0) & ")" Else RueTransforme = ""
End Function

Si Rue, Avenue, Sentier commencent par une majuscule.

24, Rue du Général De Gaulle

Général De Gaulle(24,rue du)

12 Avenue d'Alésia

Alésia(12 Avenue d')

Sentier du Four

Four(Sentier du)

Function RueTransforme2(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "(?!(Rue|Avenue|Sentier))([A-Z][a-zëéèô]+\s*-?)+"
  Set a = obj.Execute(c)
  obj.Pattern = "((\d{0,4}[\s,]?[A-Z][a-z]+)\s[a-z']+)+"
  Set b = obj.Execute(c)
  If a.Count > 0 Then RueTransforme2 = a(0) & "(" & b(0) & ")" Else RueTransforme2 = ""
End Function

Extraction des occurences d'une chaîne

RegExp

02/01/2012* * Action * 22,00 19/12/2011* * Action * 45,00 12/12/2011* * Action * 22,00 02/12/2011* * Action * 6,90 30/11/2011* * Action * 6,90 25/11/2011* * Action * 2,81

02/01/2012* * Action * 22,00
19/12/2011* * Action * 45,00
12/12/2011* * Action * 22,00
02/12/2011* * Action * 6,90
30/11/2011* * Action * 6,90
25/11/2011* * Action * 2,81

Function Extrait(c, n)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d{2}/\d{2}/20\d{2}\* \* Action \* \d+,\d{2}"
  Set a = obj.Execute(c)
  If a.Count > 0 And n <= a.Count Then Extrait = a(n - 1) Else Extrait = ""
End Function

Function ExtraitN(c, n)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+,\d{2}"
  Set a = obj.Execute(c)
  If a.Count > 0 And n <= a.Count Then ExtraitN = a(n - 1) Else ExtraitN = ""
End Function

Chaîne

Pattern

Résultat

ABN AMRO BANK NV 3.375% 21/01/2014

\d+.*\d*%

3.375%

Découpage d'une chaîne

Les chaînes de la colonne A sont découpées en Colonnes B,C,D

Découpe

Function Num(chaine, n)
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d{5,12}"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then Num = a(n - 1) Else Num = ""
End Function

Function debut(chaine)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Pattern = "[a-zA-Z_/%20]+"
  Set a = obj.Execute(chaine)
  If a.Count > 0 Then debut = Mid(a(0), 2) Else debut = ""
End Function

Solution classique + rapide (0,06sec pour 3.000 lignes)

Sub essai2()
  n = [A65000].End(xlUp).Row
  a = [A2].Resize(n).Value
  Dim result()
  ReDim result(1 To n, 1 To 3)
  For i = 1 To n
    temp = "/"
    b = Split(a(i, 1), "/")
    j = 1: témoin = True
    Do While j <= UBound(b) And témoin
      If Not IsNumeric(b(j)) Then temp = temp & b(j) & "/": j = j + 1 Else témoin = False
    Loop
    result(i, 1) = Mid(temp, 2)
    If j = UBound(b) + 1 Then result(i, 1) = Left(result(i, 1), Len(result(i, 1)) - 1)
    If j < UBound(b) Then result(i, 2) = b(j)
    If j + 1 <= UBound(b) Then result(i, 3) = b(j + 1)
  Next i
  [B2].Resize(n, 3).Value = result
End Sub

Extrait les montants en €, $ ,CHF

ExtractionMontantEuros

Function ExtraitN(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+(,|\.)*\d{0,2}\s*(€|\$|CHF)"
  Set a = obj.Execute(c)
  tmp = ""
  For i = 0 To a.Count - 1
    tmp = tmp & a(i) & "+"
  Next i
  ExtraitN = "=" & Replace(Left(tmp, Len(tmp) - 1), " ", "")
End Function

Function Total(c)
  Application.Volatile
  Set obj = CreateObject("vbscript.regexp")
  obj.Global = True
  obj.Pattern = "\d+(,|\.)*\d{0,2}\s*(€|\$|CHF)"
  Set a = obj.Execute(c)
  tmp = 0
  For i = 0 To a.Count - 1
    tmp = tmp + Val(Replace(a(i), ",", "."))
  Next i
  Total = tmp
End Function

Coloriage de caractères

Chaîne.Characters(début,longueur).colorIndex=couleur

[A1].Characters(5, 1).Font.ColorIndex = 3    ' colorie le 5e caractère en rouge


For i = 1 To Len([A1])            ' colorie tous les B en rouge
   If Mid([A1], i, 1) = "B" Then [A1].Characters(i, 1).Font.ColorIndex = 3
Next i

FonctionExtraitCouleur

Mise en gras de caractères

On veut mettre en gras le mot test dans les cellules de la colonne A contenant le mot test

MotGras

Sub essai()
  mot = "test"
  For Each c In Range("A2:A" & [A65000].End(xlUp).Row)
  p = InStr(UCase(c), UCase(mot))
  If p > 0 Then c.Characters(Start:=p, Length:=Len(mot)).Font.Bold = True
  Next c
End Sub

On veut mettre en gras les mots avant le caractère :

Mise en gras

Sub MiseGrasAvant2Points()
  Set f = Sheets("feuil1")
  car = ":"
  For Each c In f.Range("A2:A" & f.[A65000].End(xlUp).Row)
    pSL = 85
    Do
      pCar = InStr(pSL, c, car)
      pFin = InStr(pSL + 1, c, Chr(10)): If pFin = 0 Then pFin = 9999
      If pCar > 0 And pCar < pFin Then
         c.Characters(Start:=pSL, Length:=pCar - pSL).Font.Bold = True
      End If
      pSL = InStr(pSL + 1, c, Chr(10))
    Loop While pSL > 0
  Next c
End Sub

 


 

 

 

 



 

 

 

 

 

 

 

 

Exemples

Fonctions chaînes
Fonction num chaîne
Fonction num chaîne2
Inverse nom prénom
Inverse prénom nom
Concaténe textes Couleur
Extrait Gras
Sans doublons Trié
Sans Accent
NomPropre
Concaténe Champ
Recherche tous
RechPartie Code
Recherche tous Champ
Sans Civilité
Bon Caractère