Funkcje Użytkownika oparte o Wyrażenia Regularne   strona główna:
A po co ten Excel ;-)
 
     W tym miejscu chciałbym zamieszczać funkcje użytkownika oparte o Wyrażenia Regularne. Nie będę jednak omawiał stosowanych  
metod dot. RegExp odsyłając ciekawych do mojego art. omawiającego tę tematykę. Funkcje starałem się napisać tak żeby oprócz  
zwykłego ciągu przyjmowały również (i zwracały) arg. Tablicowe. Przez co można będzie zwracać wyniki tych funkcji do zakresu    mój art. Dot. zastosowania
komórek arkusza jak również używać jako argumenty w np.: funkcji SUMA.ILOCZYNÓW   Wyrażeń Regularnych
  w Excelu
 
Zadanie.1 Funkcja Fragment_RegExp  
Mamy zestaw danych:  
 
  A B C D E  
1 01test78 1   78 {=Fragment_RegExp(A1:A13;"\d+";2)*1}  
2 02test31 2   31 formuła tablicowa wprowadzona   Tworzenie formuły tablicowej Obliczanie wielu wyników
3 03test95 3   95 do zakresu D1:D14  
4 04test32 4   32    
5 05test99 5   99    
6 06testASS 6   #N/D!    
7 07test30 7   30    
8 08test27 8   27    
9 09test1 9   1    
10 10testFDDs 10   #N/D!    
11 11test75 11   75    
12 12testDSA 12   #N/D!    
13 13test96 13   96    
14            
15 Suma komórek z zakresu B1:B13
jeżeli w zakresie A1:A13 jest druga liczba
63 =SUMA.ILOCZYNÓW(
(CZY.LICZBA(Fragment_RegExp(A1:A13;"\d+";2)*1))*(B1:B13))
 
16            
17 Ile ciągów z zakresu A1:A13 nie posiada "drugiej" liczby 3 =SUMA.ILOCZYNÓW(
--(CZY.BŁĄD(A1:A13)))
 
 
I sama funkcja:  
 
Function Fragment_RegExp(vText As Variant, _  
                         strPattern As String, _  
                         Optional iCol As Integer = 1) As Variant  
    On Error GoTo Fragment_RegExp_Error  
                         
    Dim objRegExp As Object 'VBScript.RegExp  
    Dim tbl As Variant, vItem As Variant  
    Dim tblWyniki() As Variant, w As Long  
      
    Set objRegExp = VBA.CreateObject("VBScript.RegExp")  
    With objRegExp  
        .Global = True  
        .Pattern = strPattern  
        If IsArray(vText) Then  
            tbl = vText  
            ReDim tblWyniki(1 To UBound(tbl), 1 To 1)  
            On Error Resume Next  
            For w = 1 To UBound(tbl)  
                vItem = Empty  
                vItem = .Execute(tbl(w, 1))(iCol - 1)  
                tblWyniki(w, 1) = IIf(IsEmpty(vItem), CVErr(xlErrNA), vItem)  
            Next  
            On Error GoTo Fragment_RegExp_Error  
            Fragment_RegExp = tblWyniki  
        Else  
            Fragment_RegExp = .Execute(vText)(iCol - 1)  
        End If  
    End With  
      
Fragment_RegExp_Exit:  
    On Error GoTo 0  
    Set objRegExp = Nothing  
    Exit Function  
 
Fragment_RegExp_Error:  
    Fragment_RegExp = CVErr(xlErrNA)  
    Resume Fragment_RegExp_Exit  
 
End Function  
 
 
Zadanie.2 Funkcja Replace_RegExp  
Należy podminić kod pocztowy i miasto na zdefiniowany przez użytkownika ciąg.  
 
  A B C  
1 testABCD 01 81-174 miastoX   testABCD 01 (kod i miasto)  
2 testABCD 02 30-253 miastoY   testABCD 02 (kod i miasto)  
3 testABCD 03 17-855 miastoZ   testABCD 03 (kod i miasto)  
4 testABCD 04 51-675 miastoAA   testABCD 04 (kod i miasto)  
5 testABCD 05 50-449 miastoAB   testABCD 05 (kod i miasto)  
6 testABCD 06 53-353 miastoA AB   testABCD 06 (kod i miasto)  
7 testABCD 07 12-786 miasto miasto   testABCD 07 (kod i miasto)  
8 testABCD 08 81-306 miastoXYZ   testABCD 08 (kod i miasto)  
9 testABCD 09 06-835 miastoXYZ   testABCD 09 (kod i miasto)  
10 testABCD 10 96-471 miastoXYZ   testABCD 10 (kod i miasto)  
11 testABCD 11 27-918 miastoXYZ   testABCD 11 (kod i miasto)  
12 testABCD 12 28-699 miastoXYZ   testABCD 12 (kod i miasto)  
13 testABCD 13 56-980 miastoXYZ   testABCD 13 (kod i miasto)  
14        
 
{=Replace_RegExp(D78:D90;"\d{2}-\d{3} .*";"(kod i miasto)")}  
 
Function Replace_RegExp(vText As Variant, _  
                        strFind As String, _  
                        Optional vReplace As Variant = vbNullString) As Variant  
 
    On Error GoTo Replace_RegExp_Error  
 
    Dim objRegExp As Object 'VBScript.RegExp  
    Dim tbl As Variant, vItem As Variant  
    Dim tblWyniki() As Variant, w As Long  
      
    Set objRegExp = VBA.CreateObject("VBScript.RegExp")  
    With objRegExp  
        .Global = True  
        .Pattern = strFind  
        If IsArray(vText) Then  
            tbl = vText  
            ReDim tblWyniki(1 To UBound(tbl), 1 To 1)  
            For w = 1 To UBound(tbl)  
                tblWyniki(w, 1) = .Replace(sourceString:=tbl(w, 1), _  
                                           replaceVar:=vReplace)  
            Next  
            Replace_RegExp = tblWyniki  
        Else  
            Replace_RegExp = .Replace(sourceString:=vText, _  
                                      replaceVar:=vReplace)  
        End If  
    End With  
 
Replace_RegExp_Exit:  
    Set objRegExp = Nothing  
    Exit Function  
 
Replace_RegExp_Error:  
    Replace_RegExp = vText  
    Resume Replace_RegExp_Exit  
 
End Function  
 
Zadanie.3 Funkcja  ZgodneZWzorcem_RegExp  
Już bez bzdurnych przykładów :-)  
Funkcja zwraca Prawda/Fałsz lub tablicę z takimi wartościami będącymi wynikiem porównania ciągu lub elementu tablicy z podanym  
wzorem  
 
Function ZgodneZWzorcem_RegExp(vWyrazenie As Variant, _  
                               strWzorzec As String) As Variant  
    On Error GoTo ZgodneZWzorcem_RegExp_Error  
 
    Dim objRegExp As Object  
    Dim tbl As Variant  
    Dim tblWyniki() As Variant, w As Long  
      
    Set objRegExp = CreateObject("VBScript.RegExp")  
    With objRegExp  
        .Global = True  
        .Pattern = strWzorzec  
        If IsArray(vWyrazenie) Then  
            tbl = vWyrazenie  
            ReDim tblWyniki(1 To UBound(tbl), 1 To 1)  
            For w = 1 To UBound(tbl)  
                tblWyniki(w, 1) = .Test(tbl(w, 1))  
            Next  
            ZgodneZWzorcem_RegExp = tblWyniki  
        Else  
            ZgodneZWzorcem_RegExp = .Test(vWyrazenie)  
        End If  
    End With  
 
ZgodneZWzorcem_RegExp_Exit:  
    Set objRegExp = Nothing  
    Exit Function  
 
ZgodneZWzorcem_RegExp_Error:  
    Resume ZgodneZWzorcem_RegExp_Exit  
 
End Function  
 
 
    Jeżli pojawią się jakieś ciekawe przykłądy wykorzystania wstawię linki. Tyle na razie :-)