Option Explicit
Sub Variante()
Dim oWsh As Worksheet
Dim mStr As String
Dim x As Long
Dim oRng As Range
Dim ToDo As Range
Dim mCol As Variant
Set oWsh = ActiveSheet
Set oRng = Selection
mStr = oRng.Text
Sheets.Add After:=Sheets(Sheets.Count)
Application.ScreenUpdating = False
For x = 1 To Len(mStr)
On Error Resume Next
Cells(1, x).Interior.ColorIndex = x
On Error GoTo 0
With Cells(2, x)
.NumberFormat = "@"
.Font.Size = 12
.Font.Bold = True
.Formula = Mid(mStr, x, 1)
End With
Next x
Range(Columns(1), Columns(x)).AutoFit
Range(Columns(x), Columns(Columns.Count)).Hidden = True
Range(Rows(3), Rows(Rows.Count)).Hidden = True
Application.DisplayFormulaBar = Not Application.DisplayFormulaBar
With ActiveWindow
.DisplayVerticalScrollBar = Not .DisplayVerticalScrollBar
.DisplayWorkbookTabs = Not .DisplayWorkbookTabs
.DisplayHeadings = Not .DisplayHeadings
End With
Application.ScreenUpdating = True
On Error GoTo errorhandler
Set ToDo = Application.InputBox(prompt:= _
"Markiere eine der oben angezeigten Farben" & Chr(13) & _
"mit der Maus und klick OK", _
Title:="Schritt 1 - Farbe wählen", Type:=8)
mCol = ToDo.Interior.ColorIndex
Do
Set ToDo = Application.InputBox(prompt:= _
"Markiere die oben angezeigten Textteile" & Chr(13) & _
"mit der Maus und klick OK" & Chr(13) & Chr(13) & _
"oder wenn fertig, Abbrechen", _
Title:="Schritt 2 - Schleife für Text wählen", Type:=8)
ToDo.Font.ColorIndex = mCol
oRng.Characters(ToDo.Cells(1).Column, ToDo.Cells.Count).Font.ColorIndex = mCol
Loop
errorhandler:
Application.DisplayAlerts = Not Application.DisplayAlerts
ActiveSheet.Delete
Application.DisplayAlerts = Not Application.DisplayAlerts
oWsh.Select
Application.DisplayFormulaBar = Not Application.DisplayFormulaBar
End Sub