|
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:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | Option Explicit
Sub Display_Second_Character()
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
cell.Offset(0, 2).Value = Mid$(cell.Value, 2, 1)
Next cell
End Sub
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | 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
Const WHAT_TO_FIND As Long = 11
Set FoundCell = ws.Range("A:A").Find(What:=WHAT_TO_FIND)
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
|