Hallo Interessierte,
auf
http://www.hostarea.de/server-09/September-8b6b79e00…
ist die xls-Datei.
Der Code ist nachfolgend, ich habe ihn auf 2 Module aufgeteilt, sie haben die Namen mdlSplit und mdlInstrRev. Die Datei enthält 2 Blätter, Split und InstrRev.
In Split wird der Trenner in B3 erwartet, der zu trennende String in B4. Ergebnisse kommen in B6, B8,B10 usw.
In InstrRev wird der zu suchende Zeichenausdruck in B3 erwartet, der zu durchsuchende String in B4
Die Position des „letzten“ Zeichenausdrucks wird in B6 angezeigt.
Die nachgebaute InstrrEv-Funktion soll schneller sein als die eingebaute InstrRev-Funktion von Excel-Vba.
Wie und ob das alles mit VB5.0 funktioniert konnte ich nicht testen
Es wäre nett, wenn mir jmd. sagen könnte, warum im InstrRev-Code bei den Parametern des Funktionsaufrufes die Angabe:
„As VbCompareMethod“
in
Optional ByVal Compare As VbCompareMethod = vbBinaryCompare
von Vba nicht akzeptiert wird, fehlt da ein Verweis, wenn ja, welcher?
Gruß
Reinhard
in Modul1 = mdlInstrRev:
Option Explicit
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" ( \_
ByVal Addr As Long, Value As Long, Optional ByVal Bytes As Long = 4)
'
Sub Test\_InstrRev()
Dim Position As Integer
Rows("5:1000").ClearContents
Position = InStrRev(Range("B4").Value, Range("B3").Value)
Cells(6, 1) = "Position:"
Cells(6, 2) = Position
End Sub
'
'VB5 bietet von Haus aus keine Rückwärts-Suche innerhalb von Strings an.
'Die folgende Routine implementiert daher die seit VB6 bekannte Funktion
'und ist (dank binärer Suche) oft sogar schneller:
Public Function InStrRev(ByRef sCheck As String, ByRef sMatch As String, \_
Optional ByVal Start As Long, Optional ByVal Compare = vbBinaryCompare) As Long
'
'( "As VbCompareMethod" wird nicht akzeptiert, fehlt da ein Verweis??? )
'
'Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
'© Jost Schwider, 29.10.2000-17.12.2000 - http://vb-tec.de/instrrev.htm
'
Dim Stopp As Long, Index As Long, Pivot As Long, Length As Long
Dim LengthPtr As Long, MatchLen As Long
#If VBA6 0 Then ' =XL97, VBA6 gibt es ab XL2000, vorher war es VBA5 bei XL97
InStrRev = VBA.InStrRev(sCheck, sMatch)
Exit Function
#End If
If Compare = vbBinaryCompare Then
MatchLen = LenB(sMatch) - 1
If MatchLen \> -1 Then
'Linke Grenze bestimmen:
Stopp = InStrB(sCheck, sMatch)
If Stopp = 0 Then Exit Function
'Rechte Grenze bestimmen:
Length = LenB(sCheck)
If Start Start Then Exit Function
LengthPtr = StrPtr(sCheck) - 4
PokeLng LengthPtr, Start + MatchLen
End If
'Ersten Treffer merken:
InStrRev = Stopp
Stopp = Stopp + 2
'Binäre Suche / Intervall-Halbierungs-Verfahren:
Do
'Ab Mitte testen:
Pivot = (Stopp + Start) \ 2
Index = InStrB(Pivot, sCheck, sMatch)
'Treffer?
If Index Then
InStrRev = Index
If Index \>= Start Then
PokeLng LengthPtr, Length
InStrRev = InStrRev \ 2 + 1
Exit Function
End If
Stopp = Index + 2
Else
If Stopp + 8 \>= Pivot Then Exit Do
Start = Pivot - 1
PokeLng LengthPtr, Start + MatchLen
End If
Loop
'Konventionell weiter machen:
Index = InStrB(Stopp, sCheck, sMatch)
Do While Index
InStrRev = Index
Index = InStrB(Index + 2, sCheck, sMatch)
Loop
InStrRev = InStrRev \ 2 + 1
'Bei grossen Zeichenketten könnte es passieren, dass der hintere Bereich
'mehrmals durchsucht werden müßte. Daher wird der String intern
'(durch temporäres Patchen der Längenangabe) gekürzt.
'So müssen bereits durchsuchte Bereiche nicht nochmal durchlaufen werden.
'Dies geschieht mit Hilfe obiger API-Deklaration
PokeLng LengthPtr, Length
Else
If Start
in Modul2 = mdlSplit:
Option Explicit
'
Sub Test\_Split()
Dim Spalte As Integer, Zerlegt As Variant
Rows("5:1000").ClearContents
Zerlegt = Split(Range("B4").Value, Range("B3").Value)
For Spalte = 0 To UBound(Zerlegt)
Cells(6 + Spalte \* 2, 1) = "String(" & Spalte & ")"
Cells(6 + Spalte \* 2, 2) = Zerlegt(Spalte)
Next Spalte
End Sub
'
Function Split(ByVal strText As String, Optional Trenner As String = " ") As Variant
' Code by Reinhard 2007
Dim Anz As Long
If strText = "" Then Exit Function ' Reaktion wie im Original
#If VBA6 0 Then ' =XL97, VBA6 gibt es ab XL2000, vorher war es VBA5 bei XL97
Split = VBA.Split(strText, Trenner)
Exit Function
#End If
If strText = "" Then Exit Function ' Reaktion wie im Original
If Trenner = "" Then Trenner = " " ' Ersatz wie im Original
strText = strText & Trenner
ReDim c(0)
While InStr(strText, Trenner)
ReDim Preserve c(Anz)
c(Anz) = Left(strText, InStr(strText, Trenner) - 1)
strText = Mid(strText, InStr(strText, Trenner) + 1)
Anz = Anz + 1
Wend
Split = c
End Function