2022. augusztus 15., hétfő

Gyorskeresés

Excel RegEx alapú szöveg-kivágó

Írta: | Kulcsszavak: Excel . VBA . RegEx

[ ÚJ BEJEGYZÉS ]

Excel topicban merült fel a kérés, de többször belefutottam már én is, így megosztom a Regular Exression-alapú kivágó függvény kódját, amint a minap dobtam össze.

A témához nem közvetlenül kapcsolódó hozzászólások inkább a Visual Basic vagy Excel topicokba menjenek.

Használatra példák:
=RegExExtract(A1)
Kiszedi a bármelyik nyitó ([{ és bármelyik 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

Copyright © 2000-2022 PROHARDVER Informatikai Kft.