Software für Sie.

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

Sub Raus_damit() Dim strInhalt As String, lngZ1 As Long, lngZn As Long, lngZ As Long Dim intS As Integer, intI As Integer, intZ As Integer intS = 1 'Spalte A lngZ1 = 1 'Erste Zeile lngZn = 25 'Letzte Zeile For lngZ = lngZ1 To lngZn strInhalt = Cells(lngZ, intS) For intI = 1 To Len(strInhalt) intZ = Asc(Mid(strInhalt, intI, 1)) If intZ >= 123 And intZ <= 255 Then Mid(strInhalt, intI, 1) = "_" Next Cells(lngZ, intS) = strInhalt Next End Sub