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

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

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

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)

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.

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

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