Erweiterung des VBA.split(). Diese Funktion kann mit Anfürhungszeichen und Maskierungen arbeiten

Download udf_splitplus.bas (V-1.1.0)

Array<String> = splitPlus(Expression [,Delimiter [, Quota]])

Public Function splitPlus( _
	ByVal iString As String, _
	Optional ByVal iDelimiter As String = ",", _
	Optional ByVal iQuote As String = """" _
) As String()

• iString String, der in einen Array zerlegt werden soll
• iDelimiter String, Delimiter. Standard ist ,
• iQuota Textbegrenzungszeichen. Standard ist “

Array<String>

'Trennung mit VBA.split()
d split("abc,'def,ghi'", ",")
<String()>  (
    [0] => <String> 'abc'
    [1] => <String> ''def'
    [2] => <String> 'ghi''
)
 
'und Dasselbe mit splitPlus
d splitPlus("abc,'def,ghi'", ",", "'")
<String()>  (
    [0] => <String> 'abc'
    [1] => <String> 'def,ghi'
)
 
'Und ein Beispiel mir Maskierten Zeichen. Maskieren immer mit \
d splitPlus("ab\,c\\,'def,g\'hi',''", ",", "'")
<String()>  (
    [0] => <String> 'ab,c\'
    [1] => <String> 'def,g'hi'
    [2] => <String> ''
)

udf_splitplus.bas

Attribute VB_Name = "udf_splitPlus"
'-------------------------------------------------------------------------------
'File         : cast_cArray.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba
'Environment  : VBA 2010 +
'Version      : 1.1.0
'Name         : cArray
'Author       : Stefan Erb (ERS)
'History      : 24.03.2015 - ERS - Creation
'               07.10.2016 - ERS - Neu lassen sich Delimiter und Seperatoren mit \ maskieren. zudem werden Leerstring jetzt richtig gehandhabt
'-------------------------------------------------------------------------------
Option Explicit
 
' /**
' * Ähnlich wie split. Zusätzlich
' * Einzelne Elemente können in Anführungszeichen gesetzt sein.
' * @param  String
' * @param  String   Delimiter   Default: ,
' * @param  String   Quota
' * @return Array<String>
' */
Public Function splitPlus(ByVal iString As String, Optional ByVal iDelimiter As String = ",", Optional ByVal iQuote As String = """") As String()
    Static rxCache As Dictionary: If rxCache Is Nothing Then Set rxCache = New Dictionary
    Dim rxKey As String: rxKey = iDelimiter & iQuote
 
    '/(?:'([^']+)'|([^,]+))/g
    If Not rxCache.exists(rxKey) Then rxCache.add rxKey, cRx("/\s*(?:" & iQuote & "([^" & iQuote & "]+)" & iQuote & "|([^" & iDelimiter & "]+))\s*/g")
 
    iString = masked2uniode(iString)
 
    If Not rxCache(rxKey).test(iString) Then splitPlus = Array(iString): Exit Function
    With rxCache(rxKey).execute(iString)
        Dim retArr() As String: ReDim retArr(.count - 1)
        Dim i As Long: For i = 0 To .count - 1
            retArr(i) = Trim(unicodeDecode(.item(i).subMatches(0) & .item(i).subMatches(1)))
            If retArr(i) = iQuote & iQuote Then retArr(i) = Empty
        Next i
    End With
    splitPlus = retArr
End Function
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http:/wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/masked2unicode
' *
' * Wandelt jedes mit \ maskierte Feld in Unicode um, ausser es handelt sich bereits um einen Unicode
' * @param  String
' * @return String
' */
Private Function masked2uniode(ByVal iString As String) As String
    Static rx As Object
    If rx Is Nothing Then Set rx = CreateObject("VBScript.RegExp"): rx.pattern = "\\(?!\\?u[0-9A-F]{4})(.)"
    masked2uniode = iString
    Do While rx.test(masked2uniode)
        'Logik siehe auch http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/char2unicode
        Dim unicode As String: unicode = rx.execute(masked2uniode)(0).subMatches(0)
        unicode = Hex(AscW(unicode)) 'Hex-Wert ermitteln
        unicode = "\u" & String(4 - Len(unicode), "0") & unicode
        masked2uniode = rx.Replace(masked2uniode, unicode)
    Loop
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * http:/wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/unicodedecode
' *
' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück
' * @param  String
' * @return String
' */
Private Function unicodeDecode(ByVal iString As String) As String
    unicodeDecode = iString
    Static rx As Object:    If rx Is Nothing Then Set rx = CreateObject("VBScript.RegExp"): rx.pattern = "\\u[0-9A-F]{4}"
    Do While rx.test(unicodeDecode)
        unicodeDecode = rx.Replace(unicodeDecode, ChrW(Replace(rx.execute(unicodeDecode)(0), "\u", "&h")))
    Loop
End Function