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 Sub

Gruß
Dirk

--
?Get it right the first time