string in selection Replace letters series from right

Question

Sub strreplace()
Dim strArr As Variant
Dim b As Byte

strArr = Array("str.", "strasse", """")

For Each x In Selection
Next

For b = 0 To UBound(strArr)
    Selection.Replace strArr(b), "straße"
Next b

End Sub

The code above should be found in a streetname example: Berlinerstr.

(Streetname in German) the series of letters (str.) to replace it to Berlinerstraße and so on Berlinerstrasse to Berlinerstraße.

How can i encode that just the first occurance of (ss, strasse) from right will be replace example: Lessonstrasse

The letters (ss) in Lesson... should not be replace.

Answer 1

Try this:

Sub test()

Dim rng As Range, r As Range

Set rng = Range("A1", "A10") 'Adjsut this Range to what ever you need.

For Each r In rng

If Right(r.Value, 4) = "str." Then

    r.Value = Replace(r.Value, "str.", "straße")

ElseIf Right(r.Value, 7) = "strasse" Then

    r.Value = Replace(r.Value, "strasse", "straße")

End If

Next r

End Sub

Answer 2

Split the string into two parts using InStrRev and insert the "ß" where required. Here's an example of how to just get the last "ss" in the string - you should be able to work logic this into your existing code:

Sub MM()

Dim names           As Variant
Dim name            As Variant
Dim newName         As String
Dim partA           As String
Dim partB           As String
Const findChar      As String = "ss"
Const replaceChar   As String = "ß"

names = Array("str.", "strasse", "Berlinstrasse", "Lessonstrasse")

For Each name In names
    If InStr(name, findChar) Then
        partA = Left(name, InStrRev(name, findChar) - 1)
        partB = Mid(name, InStrRev(name, findChar) + Len(findChar))
        newName = partA & replaceChar & partB
    End If

    Debug.Print newName

Next

End Sub

---

Ultimately you could just create a UDF to do this:

Function ReplaceSS(ByVal name As String) As String

    If InStr(name, "ss") Then
        partA = Left(name, InStrRev(name, "ss") - 1)
        partB = Mid(name, InStrRev(name, "ss") + 2)
        newName = partA & "ß" & partB
    Else
        newName = name
    End If

    ReplaceSS = newName

End Function

Answer 3

Try This

Sub test()

Dim rng As Range, r As Range

Set rng = Range("A1", "A10") 'Adjsut this Range to what ever you need.

For Each r In rng

If InStr(1, r.Value, "strasse") > 0 Then

    r.Value = replace(r.Value, "strasse", "straße")

End If

Next

End Sub

Answer 4

this one should do what you want

Sub strReplace()
    Dim strArr As Variant
    Dim b As Byte

    strArr = Array("str.", "strasse", """")

    For Each X In Selection
        For b = 0 To UBound(strArr)
            If InStrRev(X, strArr(b)) > 0 Then
                Selection.Replace X, Left(X, InStrRev(X, strArr(b)) -1) & Replace(X, strArr(b), "straße", InStrRev(X, strArr(b)))
            End If
        Next b
    Next
End Sub

Answer 5

Andrewz, some of these answers are elegant indeed, but have you posed the right question?

As a student, I spent a wonderful year in Innsbruck on a street called Schneeburggasse. Delightful though my neighbours were, I'm sure they'd turn their noses up at their street becoming Schneeburggaße. Likewise, my German pen pal used to live on a road called Schloßstraße - if that is recorded in your database as Schlossstrasse, then wouldn't Schlossstraße look a little odd?

My point is that just doing a replace of the last ss could give you some very strange results. Short of writing an incredibly complex morpheme analysis programme to apply the already flaky Eszett rules, you're going to need a more reliable workaround.

I'd suggest creating a collection of common names, like Straße, Schloß, etc. that you can be sure need to be replaced. Run a replace on those and then store any other occurrences of ss for you to loop through and check manually. Something like the code below:

Option Explicit
Private mCommonWords As Collection
Private mAmbiguous As Collection

Public Sub RunMe()
    Dim str As String
    Dim cell As Range

    CreateCommonWordList
    ReplaceOrNote

    ' Do anything you like with the list of ambiguous cells
    For Each cell In mAmbiguous
        str = str & cell.Address(False, False) & vbLf
    Next
    MsgBox str
End Sub

Private Sub CreateCommonWordList()
    Set mCommonWords = New Collection
    AddCommonWord "straße", "strasse"
    AddCommonWord "straße", "str."
    AddCommonWord "schloß", "schloss"
End Sub

Private Sub AddCommonWord(correct As String, wrong As String, Optional capitalise As Boolean = True)
    Dim words(1) As String
    Dim splitCorrect(1) As String
    Dim splitWrong(1) As String

    words(0) = correct
    words(1) = wrong
    mCommonWords.Add words
    If capitalise Then
        splitCorrect(0) = UCase(Left(correct, 1))
        splitCorrect(1) = Mid(correct, 2, Len(correct) - 1)
        correct = splitCorrect(0) & splitCorrect(1)
        splitWrong(0) = UCase(Left(wrong, 1))
        splitWrong(1) = Mid(wrong, 2, Len(wrong) - 1)
        wrong = splitWrong(0) & splitWrong(1)
        words(0) = correct
        words(1) = wrong
        mCommonWords.Add words
    End If
End Sub

Private Sub ReplaceOrNote()
    Dim ws As Worksheet
    Dim v As Variant
    Dim startCell As Range
    Dim foundCell As Range

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    ' First replace the common words
    For Each v In mCommonWords
        ws.Cells.Replace _
            What:=v(1), _
            Replacement:=v(0), _
            LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            MatchCase:=True, _
            SearchFormat:=False, _
            ReplaceFormat:=False
    Next

    ' Now search for every other 'ss' member
    Set mAmbiguous = New Collection
    Set startCell = ws.Cells.Find( _
        What:="ss", _
        After:=ws.Cells(ws.Rows.Count, ws.Columns.Count), _
        LookIn:=xlFormulas, _
        LookAt:=xlPart, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=True)

    If Not startCell Is Nothing Then
        mAmbiguous.Add startCell
        Set foundCell = startCell
        Do
            Set foundCell = ws.Cells.FindNext(foundCell)
            If foundCell Is Nothing Then
                Exit Do
            ElseIf foundCell.Address = startCell.Address Then
                Exit Do
            Else
                mAmbiguous.Add foundCell
            End If
        Loop While True
    End If
End Sub

Hi Ambie I know Innsbruck is beautiful... your code is it too. My problem is I must load up street addresses, postcode and so on too Webfleet. That is a online portal (in german) for tracking service cars (Geoposition). If I upload the daily service tour on the driver terminal TomTom 8275 the excel tool for do that reports often errors (on Geocoding) if the streetname ends with strasse. Another problem many adresses rows in the excel worksheets ends with str. (Innsbruckerstr.). So that i must replace this to Insbruckerstraße. I have test your code and he solve both problems. But on Strasserstr. he change it to Straßerstraße i think because the letter series strasse is in strasser. OK i can live with that...thanks again

Answer 6

You can use StrReverse to start from the end of the string and specify in the Replace method, the maximal number of replacement that you want to do :

Public Function Replace(
   ByVal Expression As String,
   ByVal Find As String,
   ByVal Replacement As String,
   Optional ByVal Start As Integer = 1,
   Optional ByVal Count As Integer = -1,
   Optional ByVal Compare As CompareMethod = CompareMethod.Binary
) As String

Here is your code with the restricted replace :

Sub strreplace()
Dim strArr As Variant
Dim b As Byte
Dim x As Range

strArr = Array("str.", "strasse", """")

For Each x In Selection.Cells
    For b = 0 To UBound(strArr)
        Cells(x.Row, x.Column) = StrReverse(Replace(StrReverse(x.Value), strArr(b), "straße", 1, 1))
    Next b
Next x
End Sub