AW: die Wechsel fehlen ja noch.
05.07.2016 14:20:18
UweD
- Ich war davon ausgegangen, so wie in der Datei, dass Leerzeichen in den Klammern vorhanden sind.
Wenn dem nicht so ist, dann wird es kürzer.
- Desweiteren, nur einstellige Ziffern
Hier noch der eingebaute Zähler zum Wechsel der Buchstaben
Option Explicit
Sub ABC()
Dim Zelle, TXT
Dim Pos1 As Integer, Pos2 As Integer, ANZ As Integer, Bis As Integer
Dim i As Integer, j As Integer, k As Integer, l As Integer, z As Integer
Dim Wechsel As Integer
Dim Erst As String, TMP As String
With ActiveSheet
.Range("B:XX").ClearContents
For Each Zelle In .Columns(1).SpecialCells(xlCellTypeConstants, 3)
'Leerzeichen in den () löschen
TMP = Zelle
ANZ = Len(TMP) - Len(Replace(TMP, "(", ""))
For i = 1 To ANZ
Pos1 = WorksheetFunction.Find("(", TMP)
Pos2 = WorksheetFunction.Find(")", TMP)
TMP = Left(TMP, Pos1 - 1) & "[" & _
Replace(Mid(TMP, Pos1 + 1, Pos2 - Pos1 - 1), " ", "") & _
"]" & Mid(TMP, Pos2 + 1)
Next
'Aufspalten
z = 1
TXT = Split(TMP, " ")
For j = 0 To Ubound(TXT)
Erst = Left(TXT(j), 1)
If IsNumeric(Erst) Then
If Mid(TXT(j), 2, 1) = "[" Then
ANZ = Len(TXT(j)) - 3
Else
ANZ = 1
End If
For k = 1 To Erst
For l = 1 To ANZ
Zelle.Offset(0, z) = Mid(Replace(TXT(j), "[", ""), l + 1, 1)
z = z + 1
Next l
Next k
Else
Zelle.Offset(0, z) = TXT(j)
z = z + 1
End If
Next
'Wechsel berechnen
Wechsel = 0
For k = 2 To z
If .Cells(Zelle.Row, k + 1) <> .Cells(Zelle.Row, k) Then
Wechsel = Wechsel + 1
End If
Next
Zelle.Offset(0, z + 2) = "Wechsel: " & Wechsel - 1
Next
End With
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0
Gruß UweD