Buchstabenkombinationen bilden

Zufällig lief im Hintergrund eine dieser Fernsehsendungen, bei der man durch das Beantworten einer Frage etwas gewinnen kann. Unter anderem gab es dort eine Matrix aus drei mal drei Feldern, die Buchstaben enthielt. Man musste daraus einen sinnvollen Begriff bilden, beim Sender anrufen und deren Konto füllen.

Nachdem irgendwann tatsächlich jemand durchkam nannte dieser einen Begriff bestehend aus acht Buchstaben.

Also habe ich mir gedacht, dass man ja mit Excel und VBA alle Kombinationen durchprobieren könnte, was bei neun Buchstaben noch in annehmbarer Zeit machbar ist.

Bei mehr Buchstaben bräuchte man ein Wörterbuch, so dass man schon beim Erstellen der Kombinationen Zweige ausblenden kann, die keine sinnvollen Kombinationen mehr zulassen. Leider fehlt es mir an solch einer Textdatei, deshalb werden alle Kombinationen in ein Tabellenblatt geschrieben. Wenn ich irgendwann einmal so etwas finde, wird auch das angepackt.

Ich habe auch noch Code dabei, der das Wörterbuch von Office benutzt und die Zellen mit vorhandenen Wörtern markiert, das ist aber so quälend langsam, dass man nur mit sehr viel Zeit darangehen sollte.

Als weitere Möglichkeit wird jeder Begriff daraufhin untersucht, ob er in einer Textdatei vorkommt, die entsprechende Zelle wird dann rot markiert. Das ist um ein vielfaches schneller, scheitert aber meistens an der entsprechenden Textdatei

Dadurch, dass Rekursionen benutzt werden, ist der eigentliche Code recht kurz, macht es aber nicht gerade leicht, ihn zu verstehen. Für mich ist diese Methode aber einfacher, als das gleiche iterativ zu realisieren. Ich bin mir auch nicht hundertprozentig sicher, ob wirklich alle Möglichkeiten ausgegeben werden, aber bei vier Buchstaben hat es ohne Probleme geklappt, deshalb sollte das auch bei mehr Buchstaben funktionieren. Gleiche Kombinationen, die durch das mehrfache vorkommen eines Buchstabens auftreten können, werden nicht ausgegeben.

Beispieldatei (Buchstabenkombi.zip 20 kB) 

In ein allgemeines Modul:  

Option Explicit
Dim colErg As Collection
Public Sub Kombis()
Dim strAusgang       As String
Dim varItem          As Variant
Dim lngZeile         As Long
Dim lngSpalte        As Long
Dim lngAnzahl        As Long
Dim i                As Long


strAusgang = LCase(Worksheets(1).Range("A1"))
Set colErg = New Collection
Kombi strAusgang, 0
lngAnzahl = colErg.Count
   With Worksheets(2)
      .Cells.Clear
      .Cells.Font.ColorIndex = 0
      .Cells.Interior.ColorIndex = xlNone
      lngSpalte = 1
      For Each varItem In colErg
         lngZeile = lngZeile + 1
         If lngZeile > 65536 Then
            lngZeile = 1
            lngSpalte = lngSpalte + 1
         End If
         .Cells(lngZeile, lngSpalte).Value = varItem
         i = i + 1
         If i Mod 100 = 0 Then Application.StatusBar = i _
            & " von insgesamt " & lngAnzahl
      Next
   End With
Application.StatusBar = False
End Sub

Private Sub Kombi(ByVal strText As String, lngPos As Long)
   Dim strDummy   As String
   Dim strAct     As String
   Dim strLeft    As String
   Dim strRight   As String
   Dim strRest    As String
   Dim strBefore  As String
   Dim i          As Long
   Dim k          As Long
   On Error Resume Next
   If lngPos = Len(strText) - 1 Then
      colErg.Add strText, strText
      Exit Sub
   End If
   If lngPos <> 0 Then strBefore = Left(strText, lngPos)
   strDummy = Mid(strText, lngPos + 1)
   k = Len(strDummy)
   For i = 1 To k
      strLeft = "":  strRight = ""
      strAct = Mid(strDummy, i, 1)
      If i > 1 Then strLeft = Left(strDummy, i - 1)
      If i < k Then strRight = Mid(strDummy, i + 1)
      strRest = strAct & strLeft & strRight
      Kombi strBefore & strRest, lngPos + 1
   Next
End Sub

In das Klassenmodul eines Tabellenblattesl:   

Option Explicit

Private Sub cmdCheck_Click()
Dim rngCheck   As Range
Dim strCheck   As String
Dim i          As Long
Me.Cells.Font.ColorIndex = 0
Me.Cells.Interior.ColorIndex = xlNone

For Each rngCheck In Me.UsedRange
   strCheck = rngCheck.Value
   If strCheck <> "" Then
      If Application.CheckSpelling(strCheck) = True Then
         rngCheck.Interior.ColorIndex = 3
      End If
      i = i + 1
      If i Mod 100 = 0 Then Application.StatusBar = _
         "Überprüfe Nr : " & i & "   " & strCheck
   End If
Next
Application.StatusBar = False
End Sub

Private Sub cmdQuickCheck_Click()
Dim rngCheck   As Range
Dim strCheck   As String
Dim strDic     As String
Dim strSearch  As String
Dim i          As Long
Dim FF         As Long

Me.Cells.Font.ColorIndex = 0
Me.Cells.Interior.ColorIndex = xlNone

strDic = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If LCase(strDic) <> "falsch" And LCase(strDic) <> "false" Then
   If Dir(strDic) = "" Then Exit Sub
Else
   strDic = "C:\Dokumente und Einstellungen\Michael Schwimmer\" & _
      "Eigene Dateien\thesaurus.txt\thesaurus.txt"
   If MsgBox("Defaultdatei benutzen?", vbOKCancel, strDic) <> _
      vbOK Then Exit Sub
End If

FF = FreeFile
Open strDic For Binary As FF
  strCheck = String(LOF(FF), 0)
  Get FF, , strCheck
  strCheck = LCase(strCheck)
Close

For Each rngCheck In Me.UsedRange
   strSearch = rngCheck.Value
   If strSearch <> "" Then
      If InStr(strCheck, strSearch) Then
         rngCheck.Interior.ColorIndex = 3
      End If
      i = i + 1
      If i Mod 100 = 0 Then Application.StatusBar = _
         "Überprüfe Nr : " & i & "   " & strSearch
   End If
Next
Application.StatusBar = False

End Sub