选择中的字符串从右边替换字母系列

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

上面的代码应该在街道名称示例中找到：Berlinerstr。

（德语中的街道名称）系列字母（str。）将其替换为Berlinerstraße，以及Berlinerstrasse到Berlinerstraße。

我如何编码只是从右边第一次出现（ss，strasse）将被替换为例：Lessonstrasse

课程中的字母（ss）不应该被替换。

Answer 1

试试这个：

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

使用InStrRev将字符串拆分为两部分，并在需要时插入“ß”。这是一个如何在字符串中获取最后一个“ss”的示例 - 您应该能够将逻辑运用到现有代码中：

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

最终你可以创建一个UDF来执行此操作：

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

试试这个

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

这个应该做你想做的事

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，其中一些答案确实很优雅，但你提出了正确的问题吗？

作为一名学生，我在因斯布鲁克的一条名为Schneeburggasse的街道度过了美好的一年。虽然我的邻居很愉快，但我确信他们会在他们的街道上变成Schneeburggaße。同样地，我的德国笔友住在一条名为Schloßstraße的公路上 - 如果你的数据库记录为Schlossstrasse，那么Schlossstraße看起来有点奇怪吗？

我的观点是，只是替换最后一个ss可能会给你一些非常奇怪的结果。如果没有编写令人难以置信的复杂语素分析程序来应用已经过时的Eszett规则，那么您将需要更可靠的解决方法。

我建议创建一系列常用名称，例如Straße，Schloß等，您可以确定需要更换它们。对它们运行替换，然后存储任何其他出现的ss供您循环并手动检查。类似下面的代码：

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

嗨Ambie我知道因斯布鲁克很漂亮......你的代码也是如此。我的问题是我必须加载街道地址，邮政编码等Webfleet。这是一个跟踪服务车（Geoposition）的在线门户网站（德语）。如果我在驱动程序终端TomTom 8275上传日常服务导览，那么excel工具会报告经常错误（在地理编码上），如果街道名称以strasse结尾。许多在excel工作表中处理行的另一个问题以str结尾。 （Innsbruckerstr）。因此，我必须将其替换为Insbruckerstraße。我测试了你的代码，他解决了这两个问题。但是在Strasserstr上。他把它换成了Straßerstraße我觉得因为字母系列strasse在strasser。好的，我可以忍受......再次感谢

Answer 6

您可以使用StrReverse从字符串末尾开始，在Replace method中指定，您想要执行的最大替换次数：

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

以下是限制替换的代码：

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