Auf einem Blatt sollen mehrere Unterstriche am Stück auf jeweils einen reduziert werden.
Wenn vorher bekannt ist, wie viele Unterstriche enthalten sein können, kann das verwendet werden:
Sub Unterstriche() Dim intI As Integer Application.ScreenUpdating = False '10 = maximale Zahl der Unterstriche For intI = 1 To 10 Range("A1:A65536").Replace What:="__", Replacement:="_", LookAt:=xlPart, SearchOrder:=xlByRows Next Range("A1").Select Application.ScreenUpdating = True End Sub
Ansonsten kann auch eine While-Schleife so lange laufen, wie noch doppelte Unterstriche gefunden werden:
Dim objGef As Object Set objGef = Cells.Find("__") Do While Not objGef Is Nothing Cells.Replace "__", "_" Set objGef = Cells.Find("__") Loop
Variante mit regulären Ausdrücken:
Sub Doppelte_Unterstriche() Dim strRepl As String, rngZelle As Range Dim Regex As Object, regMatches, regMatch If Regex Is Nothing Then Set Regex = CreateObject("VBScript.RegExp") strRepl = "_" Regex.Global = True Regex.Pattern = "(__+)" For Each rngZelle In ActiveSheet.UsedRange Set regMatches = Regex.Execute(rngZelle) rngZelle = Regex.Replace(rngZelle, strRepl) Next Set Regex = Nothing End Sub