|
| |
 | In diesem Forum haben Sie die Möglichkeit Kommentare, Fragen und Verbesserungsvorschläge zu den im vb@rchiv gelisteten Tipps und Workshops zu posten.
Hinweis:
Ein neues Thema kann immer nur über die jeweilige Tipps & Tricks bzw. Workshop Seite eröffnet werden! |
Fragen zu Tipps & Tricks und Workshops im vb@rchiv| Re: Doppelte Zeichen aus einem String entfernen | |  | | Autor: Dirk | | Datum: 13.10.10 10:38 |
| Mein Vorschlag dafür:
Private Function StripDuplicates( _
ByVal vValue As String, _
Optional ByVal vChar As String = " " _
) As String
Dim sResult As String
Dim lenValue As Long
Dim s As String
lenValue = Len(vValue)
sResult = vbNullString
If lenValue > 0 Then
Dim i As Long
Dim pos As Long
'Platz schaffen, wir wollen nicht "konkatenieren"
sResult = String(lenValue, " ")
' i: index in s
i = 1
' pos: index im result, wird nur erhöht, wenn geschrieben wird
pos = 0
'Wir laufen nur 1-Mal durch den gesamten String!
Do While i <= lenValue
s = Mid$(vValue, i, 1)
pos = pos + 1
Mid$(sResult, pos, 1) = s
If s = vChar Then
'skip redundante Zeichen
Do Until Mid$(vValue, i + 1, 1) <> vChar
i = i + 1
Loop
End If
i = i + 1
Loop
End If
StripDuplicates = Trim$(sResult)
End FunctionEdit: Typo
Gruß
Dirk
--
 ?Get it right the first time 
Beitrag wurde zuletzt am 13.10.10 um 10:40:15 editiert. | |
| Re: Doppelte Zeichen aus einem String entfernen | | | | Autor: Dirk | | Datum: 13.10.10 10:52 |
| Hier mal mein Testframework, xt ist ein Highperformance-Counter, müsstest du auskommentieren.
Option Explicit
Private Declare Sub DEBUGPRINT Lib "kernel32" Alias _
"OutputDebugStringA" ( _
ByVal lpOutputString As String _
)
Private m_CharTable As String
Private Sub cmdRun_Click()
doTest
End Sub
Private Sub Form_Load()
Me.Show
Init
End Sub
Private Sub doTest()
Dim i As Long
Dim s As String
Dim sResult As String
Dim sChar As String
Dim lenTable As Long
Dim iTblIdx As Long
Dim cnt As Long
InitRnd 1
s = CreateRandomString(255)
cnt = Val(txtRuns)
lenTable = Len(m_CharTable)
Dim xt As xTimer
Set xt = New xTimer
xt.Calibrate
DEBUGPRINT "DBGVIEWCLEAR"
xt.Start
For i = 1 To cnt
iTblIdx = i Mod lenTable
If iTblIdx = 0 Then iTblIdx = 3
sChar = Mid$(m_CharTable, iTblIdx, 1)
sResult = StripDuplicates(s, sChar)
DEBUGPRINT "[" & CStr(Len(s)) & "] " & s
DEBUGPRINT "[" & CStr(Len(sResult)) & "] " & sResult
If i Mod 50 = 0 Then DoEvents
Next i
xt.Halt
lblRes1.Caption = CStr(xt.RunTime)
xt.Start
For i = 1 To cnt
iTblIdx = ((i + 1) Mod lenTable) + 1
sChar = Mid$(m_CharTable, iTblIdx, 1)
sResult = StripDuplicates1(s, sChar)
DEBUGPRINT "[" & CStr(Len(s)) & "] " & s
DEBUGPRINT "[" & CStr(Len(sResult)) & "] " & sResult
If i Mod 50 = 0 Then DoEvents
Next i
xt.Halt
lblRes2.Caption = CStr(xt.RunTime)
End Sub
Private Sub Init()
InitCharTable
InitRnd 1
txtRuns = 1000
End Sub
Private Sub InitRnd(Optional ByVal vInitVal As Long)
If IsMissing(vInitVal) Then
Randomize Timer
Else
Rnd -1
Randomize vInitVal
End If
End Sub
Private Function StripDuplicates1( _
ByVal vValue As String, _
Optional ByVal vChar As String = " " _
) As String
Dim sResult As String
Dim lenValue As Long
Dim s As String
lenValue = Len(vValue)
sResult = vbNullString
If lenValue > 0 Then
Dim i As Long
Dim pos As Long
'Platz schaffen, wir wollen nicht "konkatenieren"
sResult = String(lenValue, " ")
' i: index in s
i = 1
' pos: index im result, wird nur erhöht, wenn geschrieben wird
pos = 0
'Wir laufen nur 1-Mal durch den gesamten String!
Do While i < lenValue
s = Mid$(vValue, i, 1)
pos = pos + 1
Mid$(sResult, pos, 1) = s
If s = vChar Then
'skip redundante Zeichen
Do Until Mid$(vValue, i + 1, 1) <> vChar
i = i + 1
Loop
End If
i = i + 1
Loop
End If
StripDuplicates1 = Trim$(sResult)
End Function
' Entfernt mehrfach vorkommende Zeichen(-ketten) aus einem String
Public Function StripDuplicates(ByVal Value As Variant, _
Optional ByVal sChar As String = " ") As Variant
If IsNull(Value) Then
StripDuplicates = Null
Else
If Value = LCase$(String$(Len(Value), sChar)) Then
Value = sChar
Else
While Len(Value) > 0 And InStr(1, Value, sChar & sChar, vbTextCompare) > 0
Value = Replace(Value, sChar & sChar, sChar)
Wend
End If
StripDuplicates = Value
End If
End Function
Private Function rndChar() As String
Dim lenTable As Long
lenTable = Len(m_CharTable)
rndChar = Mid$(m_CharTable, Int((lenTable - 1 + 1) * Rnd + 1), 1)
End Function
Private Sub InitCharTable()
Dim i As Long
Dim j As Long
m_CharTable = String(255, " ")
j = 1
For i = Asc("A") To Asc("Z")
Mid$(m_CharTable, j, 1) = Chr$(i)
j = j + 1
Next i
Mid$(m_CharTable, j, 1) = " "
j = j + 1
For i = Asc("a") To Asc("z")
Mid$(m_CharTable, j, 1) = Chr$(i)
j = j + 1
Next i
m_CharTable = Trim$(m_CharTable)
End Sub
Private Function CreateRandomString(ByVal vLen As Long) As String
Dim i As Long
Dim sResult As String
sResult = String(vLen, " ")
For i = 1 To vLen
Mid$(sResult, i, 1) = rndChar()
Next i
sResult = Trim$(sResult)
CreateRandomString = sResult
End Function
Private Sub txtRuns_Change()
Static prev As String
If Not IsNumeric(txtRuns) Then
txtRuns = prev
Else
prev = txtRuns
End If
End SubGruß
Dirk
--
?Get it right the first time | |
| Re: Doppelte Zeichen aus einem String entfernen | | | | Autor: Rollator | | Datum: 05.11.10 18:42 |
| Hallo Dirk,
StripDuplicates = Trim$(sResult)
löscht automatisch alle Leerzeichen vorne und hinten! Ein Leerzeichen ist aber erlaubt, selbst wenn der Löschwunsch sich auf doppelte Leerzeichen bezieht.
Exakter ist daher
StripDuplicates = Left$(sResult, pos)
In diesem Sinne
der
Rollator | |
| Re: Doppelte Zeichen aus einem String entfernen | | | | Autor: Rollator | | Datum: 05.11.10 19:08 |
| Hallo Herr Otter,
warum arbeiten Sie in diesem Tipp stets mit dem Typ Variant, obwohl es sich doch hier nur um Strings handeln kann?
Darüber hinaus glaube ich, dass die instr Function einige Sonderfälle sowieso korrekt behandelt, so dass eine zusätzliche Abfrage eigentlich nicht sein müsste?
Ansonsten will man häufiger auch, dass "bB" durch "b" (oder "B") ersetzt wird, der Ansatz könnte dann z.B. so aussehen:
Function ReplaceDouble _
(ByVal Text As String, ByRef Such As String, _
suchArt As VbCompareMethod) As String
' TKurz = ReplaceDouble("abBbcbbb", "b", vbTextCompare)
' entfernt so doppelte "b" aber auch "bB" -> "abcb"
' TKurz = ReplaceDouble(" b bb", " ", vbBinaryCompare)
' entfernt so doppelte " " -> " b bb"
Dim DoppelSuch As String
If LenB(Such) > 0 Then
DoppelSuch = Such + Such
Do While InStr(1, Text, DoppelSuch, suchArt) > 0
Text = Replace(Text, DoppelSuch, Such, 1, -1, suchArt)
Loop
End If
ReplaceDouble = Text
End Function
Sub ReplaceDoubleSub _
(ByRef Text As String, ByRef Such As String, suchArt As VbCompareMethod)
' Aufruf als Sub geht oft etwas schneller
' T = "abBbcbbb" : ReplaceDoubleSub T, "b", vbTextCompare
' entfernt so doppelte "b" aber auch "bB" -> "abcb"
' T = " b bb" : ReplaceDoubleSub T, " ", vbBinaryCompare
' entfernt so doppelte " " -> " b bb"
Dim DoppelSuch As String
If LenB(Such) > 0 Then
DoppelSuch = Such + Such
Do While InStr(1, Text, DoppelSuch, suchArt) > 0
Text = Replace(Text, DoppelSuch, Such, 1, -1, suchArt)
Loop
End If
End SubViele Grüße
Rollator | |
| Sie sind nicht angemeldet!
Um einen neuen Beitrag schreiben zu können, müssen Sie sich zunächst anmelden.
 Einloggen | Neu registrieren |
 |
|
vb@rchiv CD Vol.6 vb@rchiv  Vol.6
Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
Online-Update-Funktion
Entwickler-Vollversionen
u.v.m.Jetzt zugreifen Tipp des Monats sevZIP40 Pro DLL 
Zippen und Unzippen wie die Profis!
Mit nur wenigen Zeilen Code statten Sie Ihre Anwendungen ab sofort mit schnellen Zip- und Unzip-Funktionen aus. Hierbei lassen sich entweder einzelnen Dateien oder auch gesamte Ordner zippen bzw. entpacken. Weitere Infos
|
April 2024
Sie sind aktuell nicht angemeldet.
