Hallo Leute

Ich bin auf der Suche nach einem VBA-Helden. :)

AUFGABE:

Ich möchte in Excel 2013 eine Buch-Chiffre mittels VBA knacken und die gesuchten Buchstaben neben die entsprechenden Zahlen der Chiffre setzen (siehe Screenshot und Code unten).

Chiffre und Schlüssel sind bekannt.

- Spalte A im Beispiel unten nummeriert die Worte im Schlüssel.

- Als Schlüssel wird ein vorgegebener Text benutzt (Spalte B "Text").

- Die Chiffre (Spalte F "Cipher") gibt die Position des gesuchten Wortes im Schlüssel an, z.B. 11,29,27,6 (11 = 11. Wort im Text, 29 =  29. Wort im Text usw.).

- Von jedem der gefundenen Worte soll der 2. Buchstabe in Spalte D ("Buchstabe2") ausgegeben und neben die entsprechende Zahl der Chiffre in Spalte H gesetzt werden.

Der Screenshot zeigt, wie es am Ende aussehen sollte. Dafür habe ich die roten Buchstaben in Spalte H manuell eingefügt. Das Makro funktioniert nur für den ersten Buchstaben in dieser Spalte (m).

PROBLEM:

Mein Code führt das nur für die erste Zahl in der Chiffre aus.

Wie krieg ich es hin, dass das Makro die Ausgabe für die ganze Chiffre macht?

Ich bin ein blutiger Anfänger was VBA betrifft.

MEIN VORGEHEN:

Die Namen der Tabellen sind definiert.

Das erste Makro gibt den 2. Buchstaben in Spalte D ("Buchstabe2") aus.

Das zweite Makro sucht (leider nur) den ersten Wert der Chiffre und gibt diesen zwei Spalten versetzt von "Chiffre" aus (Spalte H).

Screenshot:

Code:

Option Explicit

'Defined names:
'Table "Text" in column B = "Text"
'Table "2. Buchstabe" in column D = "Buchstabe2"
'Table "Cipher" in column F = "Cipher"

Sub Display_Second_Character()

'Displays the second character of each word in table "2. Buchstabe"

Dim ws As Worksheet
Dim cell As Range
Dim Text As Range

Set ws = Worksheets("Textsuche")
Set Text = Range("Text")

    For Each cell In ws.Range("Text").Cells
'Displays result two columns to the right of the source
    cell.Offset(0, 2).Value = Mid$(cell.Value, 2, 1)
    Next cell

End Sub

Sub Find_Cell_And_Copy_Adjacent_Cell()

        Dim wb As Workbook
        Dim ws As Worksheet
        Dim FoundCell As Range
        
        Set wb = ActiveWorkbook
        Set ws = ActiveSheet
        
'Finds first figure from cipher
            Const WHAT_TO_FIND As Long = 11

            Set FoundCell = ws.Range("A:A").Find(What:=WHAT_TO_FIND)
            
'Copies found values next to corresponding cipher figure
            If Not FoundCell Is Nothing Then
                FoundCell.Offset(0, 3).Select
                Selection.Copy
                FoundCell.Offset(-10, 7).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Else
                End
            End If
End Sub

Kann mir hier jemand unter die Arme greifen? Ich bin für jede Hilfe unendlich dankbar.

Lieben Gruss an alle

Mohnsoon