Sub VerkettenUndEinfarben()
'
Dim Strasse As String, ID As String, Ergenis As String
Dim Beginn As Integer, Lange As Integer, i As Integer
i = 4
While Sheets("Ibk-h-1932").Range("B" & i).Value2 <> ""
Strasse = Sheets("Ibk-h-1932").Range("J" & i).Value2
ID = Sheets("Ibk-h-1932").Range("B" & i).Value2
Ergebnis = Strasse & " (ID """ & ID & """)"
Beginn = Len(Strasse) + 7
Lange = Len(ID)
With Sheets("Collecte-Ibk-1932")
.Hyperlinks.Add .Range("F" & i), Address:="https://excel-downloads.com/threads/colorier-un-partie-dun-txt.20086026/post-20676396"
With .Range("F" & i)
.Value2 = Ergebnis
With .Font
.Underline = False
.Name = "Times New Roman"
.Size = 20
.Color = vbBlack
End With
With .Characters(Beginn, Lange).Font
.Bold = True
.Color = vbRed
End With
End With
End With
i = i + 1
Wend
End Sub