Belgilangan satr Belgilar qatorini o'ngdan o'rnating

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

Yuqoridagi kodni streetname misolida topish mumkin: Berlinerstr.

(Germaniyadagi Streetname) Berlinerstraße va shunga o'xshash Berlinerstrasse Berlinerstrasse bilan almashtirish uchun bir qator harflar (str.)

Qanday qilib kodlashim mumkinki, (ss, strasse) o'ngdan birinchi marta paydo bo'lishi misol o'rnini oladi: Lessonstrasse

Kursdagi harflar (s) ... o'rnini bosa olmasligi kerak.

1

6 javoblar

InStrRev yordamida simni ikki qismga bo'linib, kerak bo'lganda «ß» ni kiriting. Quyida faqatgina oxirgi "s" ni mag'lubiyatga qanday qilib olish mumkinligi haqidagi misol mavjud. Buni mantiqni mavjud kodingizga kiritishingiz kerak:

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

Nihoyat, buni amalga oshirish uchun faqat UDF yaratishingiz mumkin:

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
1
qo'shib qo'ydi
Bu "Lessonstrasse" ni "Lessonstraße" ga o'zgartiradi - bu sizga kerakli emasmi?
qo'shib qo'ydi muallif Macro Man, manba
Xristian MacRo Man, men sizning echimingizni ko'rib chiqdim, lekin kutilgan natijani olishingiz mumkin :-(
qo'shib qo'ydi muallif andrewz, manba

Andrewz, bu javoblarning ba'zilari chiroyli, lekin siz to'g'ri savol bergansiz?

Talaba sifatida men Schneeburggasse nomli ko'chada Insbrukda ajoyib yil o'tkazdim. Qo'shnilarim rosa xursand bo'lgan bo'lsa-da, men ularning burunlarini Shneeburggasga aylantirmoqdalar. Xuddi shu singari mening germaniyalik kalamushchim Schloßstraße nomli yo'lda yashashga odatlangan edi - bu sizning ma'lumotlar bazasida Schlossstrasse sifatida qayd etilgan bo'lsa, unda Schlossstraße biroz g'alati ko'rinish bermaydimi?

Mening fikrimcha, oxirgi paytlarda sizni juda g'alati natija berishi mumkin. Eski qoidalarni qo'llash uchun juda murakkab morfemalarni tahlil qilish dasturini yozishni qisqartirishingiz kerak, siz ko'proq ishonchli hal qilishingizga to'g'ri keladi.

Straße, Schloß va boshqalar kabi umumiy nomlar to'plamini yaratishni taklif qilishni taklif qilaman. Ularni almashtirishni boshlang va keyin sizning qo'l bilan tekshiring va tekshiring. Quyidagi kodga o'xshash narsa:

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

Salom Ambie bilaman, Innsbruck yaxshi ... sizning kodingiz ham shu. Mening muammomni ko'cha-manzillar, pochta indeksi va shunga o'xshash veb-fayllarni yuklash kerak. Bu xizmat portallari (Geoposition) monitoringini o'tkazish uchun onlayn portal (german tilida). Agar TomTom 8275 haydovchilar terminalida haydovchi terminaliga yuklasam, unda ko'cha adi strasse bilan tugagan bo'lsa, u tez-tez xatolar (Geocoding bo'yicha) haqida hisobot beradi. Excel jadvalidagi ko'pgina satrlarni boshqa bir muammo, str bilan tugaydi. (Innsbruckerstr.). Buni men Insbruckerstraße ga almashtirishim kerak. Sizning kodingizni sinab ko'rdim va u ikkala muammolarni ham hal qildi. Lekin Strasserstr. u Straßerstraßega o'zgartiradi, deb o'ylayman, chunki harflar seriyasidagi harflar strasserda. OK, bu bilan yashay olaman ... yana rahmat

1
qo'shib qo'ydi

Buni ko'ring:

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
1
qo'shib qo'ydi

bu siz xohlagan narsani qilish kerak

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
1
qo'shib qo'ydi
O'zingiz haqingiz bor, almashtirilgan oldni qo'shib qo'yishni unutib qo'ying, hozir ham o'rnatib qo'ying
qo'shib qo'ydi muallif tsolina, manba
Xristian tsolina bu echim ishlaydi, lekin "straße" dan oldin barcha harflarni kesadi. Masalan: Lessonstrasse oldida Kursdan so'ng straße. To'g'ri, shunday bo'ladi: Lessonstraße
qo'shib qo'ydi muallif andrewz, manba

Buni ko'ring

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
1
qo'shib qo'ydi
Sizning javobingiz uchun thx, ammo sublimanizning qaytishi misolda paydo bo'lgan barcha harflarni o'zgartiradi: Lessonnstrasse ga Lešsonstraße ga to'g'ri tushuntirish "Lessonstraße"
qo'shib qo'ydi muallif andrewz, manba

StrReverse dan foydalanishingiz mumkin va https://msdn.microsoft.com/fr-fr/library/bt3szac5(v = .90) .aspx "rel =" nofollow "> O'zgartirish usuli amalga oshirish kerak bo'lgan maksimal sonini kiriting:

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

Sizning cheklovlaringiz bilan sizning kodingiz quyidagilardan iborat:

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
0
qo'shib qo'ydi
Hmm ... Bu ishlashi kerak edi, lekin baribir, uni Cells() bilan almashtirdim va bu hiyla qilish kerak, menga xabar bering! ;)
qo'shib qo'ydi muallif R3uK, manba
@andrewz: Menga bu sahifada hozircha to'g'ri chop etishini bilib qo'ying! ;)
qo'shib qo'ydi muallif R3uK, manba
Xotirangiz R3uK sizning yechimingiz aqlga o'xshab ko'rinadi, lekin sub-natija bermaydi. Men bu satrni deb o'ylayman: "x.Value = StrReverse (almashtirish (StrReverse (x.Value), strArr (b)," straße ", 1, 1))" Don, t ishlaydi ...?
qo'shib qo'ydi muallif andrewz, manba