XL 2019 Extraire une suite de 4 chiffres dans une désignation

Amilo à dit:

Re,

Merci patricktoulon pour l'optimisation du code, finalement j'oublie l'histoire du camion surchargé pour le RegEx ,

Bonne soirée à tous

Cliquez pour agrandir...

Staple1600 à dit:

Re

Apparemment la cape d'invisibilité est retombée sur mes épaules

(cf message#7 et #9)

Cliquez pour agrandir...

Staple1600 à dit:

Re

Apparemment la cape d'invisibilité est retombée sur mes épaules

(cf message#7 et #9)

Cliquez pour agrandir...

Staple1600 (il y a bientôt une heure de cela) à dit:

Enrichi (BBcode):

Function QUATRE(s As String) As Double
With CreateObject("vbscript.regexp")
  .Pattern = "\d{4}"
  If .Test(s) Then QUATRE = CDbl(.Execute(s)(0))
End With
End Function

EDITION 1: Bonsoir patricktoulon
EDITION 2: Bonsoir laurent950

Cliquez pour agrandir...

patricktoulon à dit:

que l'on pourrait isoler les chaines \d{4}

VB:

Public regex As Object
Public Function RegExpExtract(Text As Range, Pattern As String, Optional Item As Integer = 1) As String
    If regex Is Nothing Then Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "(\s)(" & Pattern & ")\s": regex.Global = True
        Set matches = regex.Execute(Text.Value)
        If matches.Count > 0 Then RegExpExtract = Trim(matches(Item - 1))
        With Sheets("Exemple").ListObjects("Tableau2")
            If .ListRows(.ListRows.Count).Range.Row = [B:B].End(xlUp).Row Then Set regex = Nothing: MsgBox "l'object a été detruit "
        End With
End Function

Cliquez pour agrandir...

Sub ChapII_A_2_b_V1()
' Cocher : Menu Outils > Reférences > Microsoft VBScript Regular Expressions
' II-A-2-b
Dim Chaine As String
    Chaine = Cells(22, 2)

'Dim reg As VBScript_RegExp_55.RegExp
'Dim Match As VBScript_RegExp_55.Match
'Dim Matches As VBScript_RegExp_55.MatchCollection

' instanciation
    'Set reg = New VBScript_RegExp_55.RegExp
    Set reg = CreateObject("VBScript.RegExp")

reg.Pattern = "(\d.*\d[\%])"  '"(\s\d\s)(\d?\d[^\w\.@-])" / reg.Pattern = "[B]^[/B](\d.*\d[\%])\s"
' Paramétrage :
    reg.MultiLine = False ' ............ Active ou non la recherche sur plusieurs lignes à la fois.
    reg.IgnoreCase = False ' ........... Précise si la recherche est sensible ou non à la casse (majuscules/minuscules).
    reg.Global = True ' ................ Précise si la recherche porte sur la première occurence ou sur toutes.
' Test si pattern Trouvé
    MsgBox reg.Test(Chaine)
' Progamme
Set Matches = reg.Execute(Chaine) ' reg.Execute("capacité")
    reg.Pattern = "(\d{4})"
    Set Matches = reg.Execute(Chaine)
For Each Match In Matches
    Debug.Print "source >>", Match.Value
    MsgBox "source >> " & Match.Value
    For i = 0 To Match.SubMatches.Count - 1
        Debug.Print "[$" & i + 1 & "]", Match.SubMatches(i)
        MsgBox "[$" & i + 1 & "] " & Match.SubMatches(i)
    Next i
Next Match
' libération d'objets
    Set Matches = Nothing
    Set Match = Nothing
    Set reg = Nothing
End Sub

CBrd à dit:

Le problème aussi est que la suite de 4 chiffres ne se trouve pas forcément toujours au même endroit.

Cliquez pour agrandir...