Extraction de caract

Bonjour,

Tu copies cette fonction personnalisée dans un MODULE STANDARD du projetVBA
du classeur.
et dans la cellule de ton choix, tu inscris : =Extraire_RGP(A1) en
supposant que A1 contient ladite chaîne de caractères.

'--------------------------------------------------
Function Extraire_RGP(Rg As Range)
Dim T As String, S As Variant, R As String
Dim G As Long, X As String
T = Rg.Value
S = Split(T, UCase("RGP"))

If UBound(S) = 0 Then
Extraire_RGP = ""
Exit Function
End If

For G = 1 To Len(S(1))
If IsNumeric(Mid(S(1), G, 1)) Then
X = X & Mid(S(1), G, 1)
Else
If X <> "" And (Mid(S(1), G, 1) = " " Or Mid(S(1), G, 1) = "-") Then
R = R & X & "-"
If UBound(Split(R, "-")) = 2 Then Exit For
X = ""
End If
End If
Next
If R <> "" Then
R = "RGP" & "-" & Left(R, Len(R) - 1)
End If
Extraire_RGP = R
End Function
'--------------------------------------------------

Le 21/05/2014 17:33, Martinella a écrit :

Bonjour
J'essaie d'extraire à l'intérieur d'une référence produit, la famille RG qui doit renvoyer RGP, la force qui peut renvoyer 500, 750 1500 ou 2400 et la course qui renvoie 38 ou 80. Le problème étant que ces éléments ne sont jamais situés au même emplacement dans la chaîne. Si RGP n'est dans la chaîne, le renvoi n'affichera rien

références des produits commandés Famille RG Force Course
RGP 500-38-P150 （443268/00S) RGP 500 38
RGP2400-38-P150(443348/00S) RGP 2400 38
RGP 750-80-P150 (443292/00S) RGP 750 80
RMGE 150-125-P135 (442089/30S)
443328/00S (RGP1500 C38 // CU0)| P150 RGP 1500 38


J'ai testé avec les fonctions STXT et CHERCHE, j'ai pu renvoyer RGP mais je ne parviens pas à extraire les autres éléments.

Sauriez-vous quelle serait la formule à mettre en place ? Je ne m'y connais pas en VBA et si c'est possible je préfèrerais une formule

Merci d'avance pour vos lumières

Martinellaella

J'ai bien vu la réponse de MichD qui pour sûr n'est pas mauvaise.
Mais je ne saurais trop vous conseiller les RegEx (surtout si vous
les maîtrisez déjà...)

Cela donne les formules :
Famille : =RegExp(A2;"R[A-Z]+")
Force : =CNUM(REGEXP(REGEXP(A2;"R[A-Z]+ *d+";1);"d+"))
Course : =CNUM(REGEXP(REGEXP(A2;"R[A-Z]+ *d+D+d+";1);"d+";2))

----------------------------------------------------------
Pour cela vous ajoutez ceci dans une procédure Public Auto_Open
d'un module de votre classeur (procédure qui sera automatiquement
lancée à l'ouverture) ou mieux : dans votre .xlam favori :

Private Sub Make_VBS_Ref()
On Error Resume Next 'in case ref already exists
ThisWorkbook.VBProject.References.AddFromGuid
"{3F4DACA7-160D-11D2-A8E9-00104B365C9F}", 5, 5
On Error GoTo 0
End Sub

Cela éviter de faire :
Outils/Références/Microsoft VBScript Regular Expression 5.5
dans l'éditeur VBA. C'est juste à quoi ça sert...


Ensuite je vous donne mes 3 fonctions :

*RegExpCmp(<chaîne>;<regex>;<optional : case sensitive>)
qui renvoie VRAI ou FAUX selon si ça matche ou pas

*RegExp(<chaîne>;<regex>;<optional : numéro>;
<optional : case sensitive>
<optional : valeur retour>)
qui renvoie la ou les parties trouvées, ou l'index
de début, de fin ou encore la longueur.

et évidemment :
*RegExpRep(<chaîne>;<regex>;<remplacement>;<optional : case sensitive>)
qui fait les remplacements.


'----------------------------------------
Public Function RegExpCmp(s, ByVal Pattern, Optional ByVal CaSeS As
Boolean = False)
Dim Regex As Object, RegMatch As Object, MatchCollection As Object, i&,
j&, res
Set Regex = New VBScript_RegExp_55.RegExp
If TypeOf s Is Range Then s = s.Value
' If TypeOf pattern Is Range Then pattern = pattern.Value
If IsNull(s) Then s = vbNullString
If IsEmpty(s) Then s = vbNullString

With Regex
.Global = True
.IgnoreCase = Not CaSeS
.MultiLine = True
.Pattern = Pattern
End With
If IsArray(s) Then
On Error GoTo CaseI: j = UBound(s, 2)
ReDim res(1 To UBound(s, 1), 1 To UBound(s, 2))
For i = 1 To UBound(s, 1)
For j = 1 To UBound(s, 2): res(i, j) = Regex.test(s(i, j)):
Next j
Next i
GoTo FinSub
CaseI:
ReDim res(1 To UBound(s, 1), 1 To 1)
For i = 1 To UBound(s, 1): res(i, 1) = Regex.test(s(i)): Next i
GoTo FinSub
Else: res = Regex.test(s)
End If
FinSub:
RegExpCmp = res: Set Regex = Nothing
End Function
'-------------------------------------------
Public Function RegExp(s, ByVal Pattern, Optional ByVal ItemNmbr% = 0,
Optional ByVal CaSeS As Boolean = False, Optional ByVal findWhat$ = "Match")
Dim Regex As Object, MatchCollection As Object
Dim str, Patt$
Set Regex = New VBScript_RegExp_55.RegExp
Dim res() As String, i&
'If IsA(sR, "Range") Then str = sR.Value2 Else s = sR
'If IsA(Pattern, "Range") Then Patt = Pattern.Value Else Patt = Pattern
findWhat = LCase(findWhat)
Select Case findWhat ' argument checking
Case "match", "begin", "start", "end", "length", "len":
Case Else: RegExp = CVErr(xlErrValue): Exit Function
End Select

With Regex
.Global = True
.IgnoreCase = Not CaSeS
.MultiLine = True
.Pattern = Pattern
Set MatchCollection = .Execute(s)
End With
Set Regex = Nothing

If MatchCollection.Count = 0 Or (ItemNmbr > 0 And MatchCollection.Count
< ItemNmbr) Then
Select Case findWhat
Case "match": RegExp = CVErr(xlErrNA)
Case Else: RegExp = -1
End Select
Exit Function
End If

If ItemNmbr < 0 Then RegExp = MatchCollection.Count: Exit Function
Select Case findWhat
Case "match"
If ItemNmbr <= 0 Then
ReDim res(1 To MatchCollection.Count, 1 To 1): i = 1
For i = 1 To MatchCollection.Count: res(i, 1) =
MatchCollection.Item(i - 1): Next i
Else: RegExp = MatchCollection.Item(ItemNmbr - 1): Exit Function
End If
Case "begin", "start"
If ItemNmbr <= 0 Then
ReDim res(1 To MatchCollection.Count, 1 To 1)
For i = 1 To MatchCollection.Count: res(i, 1) =
MatchCollection.Item(i - 1).FirstIndex + 1: Next i
Else: RegExp = MatchCollection.Item(ItemNmbr - 1).FirstIndex + 1:
Exit Function
End If
Case "end"
If ItemNmbr <= 0 Then
ReDim res(1 To MatchCollection.Count, 1 To 1)
For i = 1 To MatchCollection.Count: res(i, 1) =
MatchCollection.Item(i - 1).Length + MatchCollection.Item(i -
1).FirstIndex: Next i
Else: RegExp = MatchCollection.Item(ItemNmbr - 1).Length +
MatchCollection.Item(ItemNmbr - 1).FirstIndex: Exit Function
End If
Case "length", "len"
If ItemNmbr <= 0 Then
ReDim res(1 To MatchCollection.Count, 1 To 1)
For i = 1 To MatchCollection.Count: res(i, 1) =
MatchCollection.Item(i - 1).Length: Next i
Else: RegExp = MatchCollection.Item(ItemNmbr - 1).Length: Exit Function
End If
End Select

If Application.Caller.Rows.Count = 1 Then
RegExp = WorksheetFunction.Transpose(res)
Else: RegExp = res
End If

End Function ' RegExp
'----------------------------------------
Public Function RegExpRep(s, ByVal Pattern$, ByVal RepStr$, Optional
ByVal CaSeS As Boolean = False)
Dim Regex As Object, MatchCollection As Object, i&, j&, res
Set Regex = New VBScript_RegExp_55.RegExp
If TypeOf s Is Range Then s = s.Value
With Regex
.Global = True
.IgnoreCase = Not CaSeS
.MultiLine = True
.Pattern = Pattern
End With
If IsArray(s) Then
On Error GoTo CaseI: j = UBound(s, 2)
ReDim res(1 To UBound(s, 1), 1 To UBound(s, 2))
For i = 1 To UBound(s, 1)
For j = 1 To UBound(s, 2)
res(i, j) = Regex.Replace(s(i, j), RepStr)
Next j
Next i
GoTo FinSub
CaseI:
ReDim res(1 To UBound(s, 1), 1 To 1)
For i = 1 To UBound(s, 1)
res(i, 1) = Regex.Replace(s(i), RepStr)
Next i
GoTo FinSub
Else: res = Regex.Replace(s, RepStr)
End If
FinSub:
RegExpRep = res: Set Regex = Nothing
End Function ' RegExpRep
'----------------------------------------

Le mercredi 21 mai 2014 20:04:24 UTC+2, MichD a écrit :

Bonjour,



Tu copies cette fonction personnalisée dans un MODULE STANDARD du proje tVBA

du classeur.

et dans la cellule de ton choix, tu inscris : =Extraire_RGP(A1) en

supposant que A1 contient ladite chaîne de caractères.



'--------------------------------------------------

Function Extraire_RGP(Rg As Range)

Dim T As String, S As Variant, R As String

Dim G As Long, X As String

T = Rg.Value

S = Split(T, UCase("RGP"))



If UBound(S) = 0 Then

Extraire_RGP = ""

Exit Function

End If



For G = 1 To Len(S(1))

If IsNumeric(Mid(S(1), G, 1)) Then

X = X & Mid(S(1), G, 1)

Else

If X <> "" And (Mid(S(1), G, 1) = " " Or Mid(S(1), G, 1) = "- ") Then

R = R & X & "-"

If UBound(Split(R, "-")) = 2 Then Exit For

X = ""

End If

End If

Next

If R <> "" Then

R = "RGP" & "-" & Left(R, Len(R) - 1)

End If

Extraire_RGP = R

End Function

'--------------------------------------------------

Merci MICHD
Je craignais ne pas y arriver car je ne connais rien en vba mais j'ai fini par trouver le module du classeur, j'y ai collé la fonction et j'ai coll é la formule dans la cellule b1 de mon classeur à la recopie tous les éléments souhaités sont ressortis. Merci beaucoup
Martinellaella

Bravo!