-
Notifications
You must be signed in to change notification settings - Fork 67
Open
Description
Hi @sancarn
In your project use many times call Replace function. The original Replace function, really slow.
I found the code below used by wqweto in some project shared by him, I trusted and tested, and the result is unbelievable that the performance is many times better than the original VBA.Replace function.
The real creator is Jost Schwider based on the comment in the code by Jost Schwider, jost@schwider.de, 20001218
You can test to take advantage of the Replace function in your project
Option Explicit
#If VBA7 = 0 Then
Private Enum LongPtr
[_]
End Enum
#End If
#If VBA7 Then
Private Declare PtrSafe Function SysAllocStringByteLen Lib "OleAut32" (ByVal olestr As LongPtr, ByVal BLen As Long) As LongPtr
Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes As LongPtr)
Private Declare PtrSafe Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes As LongPtr)
#Else
Private Declare Function SysAllocStringByteLen Lib "oleaut32" (ByVal olestr As Long, ByVal BLen As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&)
Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&)
#End If
Private Const FADF_AUTO As Long = &H1 '// Array is allocated on the stack.
Private Const FADF_FIXEDSIZE As Long = &H10 '// Array may not be resized or reallocated.
Private Sub Replace08_test()
Dim s$, t!
s = String(10000000, "a")
t = Timer
Debug.Print Replace08(s, "aaa", "")
Debug.Print "Replace08: "; Round(Timer - t, 5)
t = Timer
Debug.Print Replace$(s, "aaa", "")
Debug.Print "Replace: "; Round(Timer - t, 5)
End Sub
Public Function Replace08(ByVal Text As String, _
ByVal sOld As String, ByVal sNew As String, _
Optional ByVal start As Long = 1, _
Optional ByVal count As Long = 2147483647, _
Optional ByVal compare As VbCompareMethod = vbBinaryCompare _
) As String
' by Jost Schwider, jost@schwider.de, 20001218
If LenB(sOld) Then
If compare = vbBinaryCompare Then
Replace08Bin Replace08, Text, Text, sOld, sNew, start, count
Else
Replace08Bin Replace08, Text, LCase$(Text), LCase$(sOld), sNew, start, count
End If
Else 'Suchstring ist leer:
Replace08 = Text
End If
End Function
Private Static Sub Replace08Bin(ByRef result As String, _
ByRef Text As String, ByRef Search As String, _
ByRef sOld As String, ByRef sNew As String, _
ByVal start As Long, ByVal count As Long)
' by Jost Schwider, jost@schwider.de, 20001218
Dim TextLen As Long, OldLen As Long, NewLen As Long, ReadPos As Long
Dim WritePos As Long, CopyLen As Long, buffer As String, BufferLen As Long, BufferPosNew As Long, BufferPosNext As Long
'Ersten Treffer bestimmen:
If start < 2 Then
start = InStrB(Search, sOld)
Else
start = InStrB(start + start - 1, Search, sOld)
End If
If start Then
OldLen = LenB(sOld)
NewLen = LenB(sNew)
Select Case NewLen
Case OldLen 'einfaches Überschreiben:
result = Text
For count = 1 To count
MidB$(result, start) = sNew
start = InStrB(start + OldLen, Search, sOld)
If start = 0 Then Exit Sub
Next count
Case 0 'nur Entfernen:
'Buffer initialisieren:
TextLen = LenB(Text)
If TextLen > BufferLen Then
buffer = Text
BufferLen = TextLen
End If
'Ausschneiden:
ReadPos = 1
WritePos = 1
For count = 1 To count
CopyLen = start - ReadPos
If CopyLen Then
MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
WritePos = WritePos + CopyLen
End If
ReadPos = start + OldLen
start = InStrB(ReadPos, Search, sOld)
If start = 0 Then Exit For
Next count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
result = LeftB$(buffer, WritePos - 1)
Else
MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
result = LeftB$(buffer, WritePos + TextLen - ReadPos)
End If
Exit Sub
Case Is < OldLen 'Ergebnis wird kürzer:
'Buffer initialisieren:
TextLen = LenB(Text)
If TextLen > BufferLen Then
buffer = Text
BufferLen = TextLen
End If
'Ersetzen:
ReadPos = 1
WritePos = 1
For count = 1 To count
CopyLen = start - ReadPos
If CopyLen Then
BufferPosNew = WritePos + CopyLen
MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(buffer, BufferPosNew) = sNew
WritePos = BufferPosNew + NewLen
Else
MidB$(buffer, WritePos) = sNew
WritePos = WritePos + NewLen
End If
ReadPos = start + OldLen
start = InStrB(ReadPos, Search, sOld)
If start = 0 Then Exit For
Next count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
result = LeftB$(buffer, WritePos - 1)
Else
MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
result = LeftB$(buffer, WritePos + LenB(Text) - ReadPos)
End If
Exit Sub
Case Else 'Ergebnis wird länger:
'Buffer initialisieren:
TextLen = LenB(Text)
BufferPosNew = TextLen + NewLen
If BufferPosNew > BufferLen Then
buffer = Space$(BufferPosNew)
BufferLen = LenB(buffer)
End If
'Ersetzung:
ReadPos = 1
WritePos = 1
For count = 1 To count
CopyLen = start - ReadPos
If CopyLen Then
'Positionen berechnen:
BufferPosNew = WritePos + CopyLen
BufferPosNext = BufferPosNew + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
buffer = buffer & Space$(BufferPosNext)
BufferLen = LenB(buffer)
End If
'String "patchen":
MidB$(buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
MidB$(buffer, BufferPosNew) = sNew
WritePos = BufferPosNext
Else
'Position bestimmen:
BufferPosNext = WritePos + NewLen
'Ggf. Buffer vergrößern:
If BufferPosNext > BufferLen Then
buffer = buffer & Space$(BufferPosNext)
BufferLen = LenB(buffer)
End If
'String "patchen":
MidB$(buffer, WritePos) = sNew
WritePos = BufferPosNext
End If
ReadPos = start + OldLen
start = InStrB(ReadPos, Search, sOld)
If start = 0 Then Exit For
Next count
'Ergebnis zusammenbauen:
If ReadPos > TextLen Then
result = LeftB$(buffer, WritePos - 1)
Else
BufferPosNext = WritePos + TextLen - ReadPos
If BufferPosNext < BufferLen Then
MidB$(buffer, WritePos) = MidB$(Text, ReadPos)
result = LeftB$(buffer, BufferPosNext)
Else
result = LeftB$(buffer, WritePos - 1) & MidB$(Text, ReadPos)
End If
End If
Exit Sub
End Select
Else 'Kein Treffer:
result = Text
End If
End Sub
Metadata
Metadata
Assignees
Labels
No labels