Új hozzászólás Aktív témák

  • sztanozs

    veterán

    válasz Delila_1 #35525 üzenetére

    Használatra példák:
    =RegExExtract(A1) - kiszedi a valamelyik nyitó ([{ és valamelyik záró )]} közül a szöveget
    =RegExExtract(A1,"","@") - kiszedi az emailcím elejéről a nevet
    =RegExExtract(A1,"@","") - kiszedi az emailcím végéről a szervert
    =RegExExtract(A1,"[","]", True) - kiszedi a szögletes zárójeles szöveget (úgy hogy a zárójelet is visszaadja)

    RegExExtract.bas
    Option Explicit

    Dim rx As Object
    Const REPLACABLE = "()[]{}-+*.\"

    Public Function RegExExtract(Text As String, Optional StartMarker As String = "([{", Optional EndMarker As String = "}])", Optional Include As Boolean = False) As String
    Dim sm As String
    sm = ""
    If StartMarker <> "" Then
    Dim ix
    For ix = 1 To Len(StartMarker)
    If InStr(REPLACABLE, Mid(StartMarker, ix, 1)) > 0 Then
    sm = sm & "\" & Mid(StartMarker, ix, 1)
    Else
    sm = sm & Mid(StartMarker, ix, 1)
    End If
    Next
    sm = "[" & sm & "]"
    End If

    Dim em As String
    Dim im As String
    em = ""
    im = ""
    If EndMarker <> "" Then
    For ix = 1 To Len(EndMarker)
    If InStr(REPLACABLE, Mid(EndMarker, ix, 1)) > 0 Then
    em = em & "\" & Mid(EndMarker, ix, 1)
    Else
    em = em & Mid(EndMarker, ix, 1)
    End If
    Next
    im = "[^" & em & "]*"
    em = "[" & em & "]"
    Else
    im = ".*"
    End If

    Dim rxt As String
    If Include Then
    rxt = "(" & sm & im & em & ")"
    Else
    rxt = sm & "(" & im & ")" & em
    End If

    If rx Is Nothing Then
    Set rx = CreateObject("vbscript.regexp")
    rx.IgnoreCase = True
    rx.Global = True
    rx.MultiLine = True
    rx.Pattern = rxt
    ElseIf rx.Pattern = rxt Then
    'cached
    Else
    rx.Pattern = rxt
    End If

    Dim Matches
    Set Matches = rx.Execute(Text)
    If Matches.Count > 0 Then
    Dim M
    For Each M In Matches.Item(0).SubMatches
    If M <> "" Then
    RegExExtract = M
    Exit For
    End If
    Next
    Else
    RegExExtract = ""
    End If
    End Function

Új hozzászólás Aktív témák

Hirdetés