Seçilmiş bir aralıktaki İsimleri Standartlaştırmak için Excel VBA

Ben hem bu forumlarda hem de mükemmel bir acemiyim ve bir kullanıcının bir metin girişleri sütunu güncellemesine izin verecek kodu bir araya getirmeye çalışıyorum. Temel olarak yapmaya çalıştığım şey:

1. kullanıcıdan aralığı seçmesini isteyin

2. Aralıktaki ilk hücreden başlayın ve kodu temel alarak metni güncelleyin.

3. bu hücrede bulunan metni "temiz" metinle değiştir

4. aralıktaki bir sonraki hücreye git # 3 ile aynı şeyi yap

5. seçilen aralığın sonunda

Sub MultiFindNReplace()
Dim InputRng As Range, ReplaceRng As Range
Dim strOld As String
Dim intPosition As Integer
Dim c As Integer
Dim CountofRows As Integer

xtitleId = "Name Update"

Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Labels to be updated ", xtitleId, InputRng.Address, Type:=8)

CountofRows = InputRng.Rows.Count
MsgBox CountofRows & " rows Selected"

For c = 1 To CountofRows

strOld = ActiveCell.Value


'Replace " .COM" with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " .COM", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace ".COM" with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ".COM", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 3)))
    End If
Next i

'Replace " INC." with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " INC.", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace " LTD " with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " LTD ", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & " " & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Replace "INC." with a space
'For i = 1 To Len(strOld)
'    intPosition = InStr(1, strOld, ".COM", vbTextCompare)
'    If intPosition > 0 Then
'        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition + 3)))
'    End If
'Next i

'Remove trailing ", LA"
If Right(strOld, 4) = ", LA" Then strOld = Replace(strOld, ", LA", "")

'Remove trailing ",LA"
If Right(strOld, 3) = ",LA" Then strOld = Replace(strOld, ",LA", "")

'Remove "," (comma)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ",", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove trailing " LTÉE"
If Right(strOld, 5) = " LTÉE" Then strOld = Replace(strOld, " LTÉE", "")

'Remove trailing " LTÉE."
If Right(strOld, 6) = " LTÉE." Then strOld = Replace(strOld, " LTÉE.", "")

'Remove trailing " LIMITÉE"
If Right(strOld, 8) = " LIMITÉE" Then strOld = Replace(strOld, " LIMITÉE", "")

'Remove trailing " LTD."
If Right(strOld, 5) = " LTD." Then strOld = Replace(strOld, " LTD.", "")

'Remove trailing " CORP."
If Right(strOld, 6) = " CORP." Then strOld = Replace(strOld, " CORP.", "")

'Remove trailing " CO."
If Right(strOld, 4) = " CO." Then strOld = Replace(strOld, " CO.", "")

'Remove trailing " INCORPORATION"
If Right(strOld, 14) = " & CO" Then strOld = Replace(strOld, " INCORPORATION", "")

'Remove trailing " & CO"
If Right(strOld, 5) = " & CO" Then strOld = Replace(strOld, " & CO", "")

'Remove trailing " AND CO"
If Right(strOld, 7) = " AND CO" Then strOld = Replace(strOld, " AND CO", "")

'Remove trailing " & CO."
If Right(strOld, 6) = " & CO." Then strOld = Replace(strOld, " & CO.", "")

'Remove trailing " CO. LTD"
If Right(strOld, 8) = " CO. LTD" Then strOld = Replace(strOld, " CO. LTD", "")

'Remove trailing " & CO INC"
If Right(strOld, 9) = " & CO INC" Then strOld = Replace(strOld, " & CO INC", "")

'Remove trailing " & CO., INC."
If Right(strOld, 12) = " & CO., INC." Then strOld = Replace(strOld, " & CO., INC.", "")

'Remove trailing " CO., INC."
If Right(strOld, 10) = " CO., INC." Then strOld = Replace(strOld, " CO., INC.", "")

'Remove trailing " CO (INC)"
If Right(strOld, 9) = " CO (INC)" Then strOld = Replace(strOld, " CO (INC)", "")

'Replace "&" with "AND"
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "&", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & "AND" & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Replace "-" (hyphen) with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "-", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & " " & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove leading or trailing "THE"
If Left(strOld, 4) = "THE " Then strOld = Replace(strOld, "THE ", "")
If Left(strOld, 6) = "(THE) " Then strOld = Replace(strOld, "(THE) ", "")
If Right(strOld, 4) = " THE" Then strOld = Replace(strOld, " THE", "")
If Right(strOld, 6) = " (THE)" Then strOld = Replace(strOld, " (THE)", "")

'Remove leading or trailing "LE"
If Left(strOld, 3) = "LE " Then strOld = Replace(strOld, "LE ", "")
If Left(strOld, 5) = "(LE) " Then strOld = Replace(strOld, "(LE) ", "")
If Right(strOld, 4) = " LE" Then strOld = Replace(strOld, " LE", "")

'Remove leading or trailing "LES"
If Left(strOld, 4) = "LES " Then strOld = Replace(strOld, "LES ", "")
If Left(strOld, 6) = "(LES) " Then strOld = Replace(strOld, "(LES) ", "")
If Right(strOld, 4) = " LES" Then strOld = Replace(strOld, " LES", "")

'Remove leading "LA "
If Left(strOld, 3) = "LA " Then strOld = Replace(strOld, "LA ", "")
If Left(strOld, 5) = "(LA) " Then strOld = Replace(strOld, "(LA) ", "")


'Remove leading "(L') "
If Left(strOld, 5) = "(L') " Then strOld = Replace(strOld, "(L') ", "")

'Remove trailing " LTD", " INC", " SVC", " CTR", " LIMITED", " LIMITED PARTNERSHIP",
'" CO", " LT", " MD", " OD", " THE CO LTD", " LTEE", " LTEE CORP", " CORP", " INCORPORATED"
If Right(strOld, 4) = " LTD" Then strOld = Replace(strOld, " LTD", "")
If Right(strOld, 4) = " INC" Then strOld = Left(strOld, (Len(strOld) - 4))
If Right(strOld, 4) = " SVC" Then strOld = Replace(strOld, " SVC", "")
If Right(strOld, 4) = " CTR" Then strOld = Replace(strOld, " CTR", "")
If Right(strOld, 8) = " LIMITED" Then strOld = Replace(strOld, " LIMITED", "")
If Right(strOld, 20) = " LIMITED PARTNERSHIP" Then strOld = Replace(strOld, " LIMITED PARTNERSHIP", "")
If Right(strOld, 3) = " CO" Then strOld = Replace(strOld, " CO", "")
If Right(strOld, 3) = " LT" Then strOld = Replace(strOld, " LT", "")
If Right(strOld, 3) = " MD" Then strOld = Replace(strOld, " MD", "")
If Right(strOld, 3) = " OD" Then strOld = Replace(strOld, " OD", "")
If Right(strOld, 7) = " THE CO LTD" Then strOld = Replace(strOld, " THE CO LTD", "")
If Right(strOld, 5) = " LTEE" Then strOld = Replace(strOld, " LTEE", "")
If Right(strOld, 10) = " LTEE CORP" Then strOld = Replace(strOld, " LTEE CORP", "")
If Right(strOld, 5) = " CORP" Then strOld = Replace(strOld, " CORP", "")
If Right(strOld, 13) = " INCORPORATED" Then strOld = Replace(strOld, " INCORPORATED", "")

'Replace " INC " with a space
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, " INC ", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition) & Right(strOld, (Len(strOld) - (intPosition + 4)))
    End If
Next i

'Remove "." (period)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, ".", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove "'" (period)
For i = 1 To Len(strOld)
    intPosition = InStr(1, strOld, "'", vbTextCompare)
    If intPosition > 0 Then
        strOld = Left(strOld, intPosition - 1) & Right(strOld, (Len(strOld) - (intPosition)))
    End If
Next i

'Remove trailing " AND"
If Right(strOld, 4) = " AND" Then strOld = Replace(strOld, " AND", "")

Next c
MsgBox "Finished"
End Sub

• Bu kod, bitişik hücrelerin bir sütununa kadar bir hücrenin seçimini kabul eder.
• Aralığı verimlilik için bir diziye kopyalar
• Dizideki yayınlanan kodunuzdaki tüm değişiklikleri gerçekleştirir.
• Güncellenen diziyi tekrar seçilen aralığa yerleştirir.

Option Explicit

Public Sub MultiFindNReplace()

    Const LBLS  As String = "Labels to be updated "
    Const xNAME As String = "Name Update"

    Const OUT   As String = " .COM|.COM| INC.|INC.| INC | LTD |,|-|.|'"

    Const R1    As String = " AND|, LA|,LA| LTÉE| LTÉE.| LIMITÉE| LTD.| INCORPORATION|"
    Const R2    As String = " CORP.| CO.| & CO| AND CO| & CO.| CO. LTD| & CO INC|"
    Const R3    As String = " & CO., INC.| CO., INC.| CO (INC)| LTD| INC| SVC| CTR|"
    Const R4    As String = " LIMITED| LIMITED PARTNERSHIP| CO| LT| MD| OD| THE CO LTD|"
    Const R5    As String = " LTEE| LTEE CORP| CORP| INCORPORATED"

    Const RSIDE As String = R1 & R2 & R3 & R4 & R5

    Const L1    As String = "THE | THE|(THE) | (THE)|LE | LE|(LE) | (LE)|LES |"
    Const L2    As String = " LES|(LES) | (LES)|LA |(LA) |(L') "

    Const LSIDE As String = L1 & L2

    Dim inRng As Range, mAr As Variant, allRows As Long, i As Long, itm As Variant
    Dim outArr As Variant, rsArr As Variant, lsArr As Variant, sz1 As Long, sz2 As Long

    outArr = Split(OUT, "|")
    rsArr = Split(RSIDE, "|")
    lsArr = Split(LSIDE, "|")

    Set inRng = Application.Selection
    Set inRng = Application.InputBox(LBLS, xNAME, inRng.Address, Type:=8)

    If inRng.Columns.Count > 1 Or inRng.Areas.Count > 1 Then
        MsgBox "Please select a single (contiguous) column"
        Exit Sub
    End If

    allRows = inRng.Rows.Count
    MsgBox allRows & " rows Selected"

    If inRng.Count = 1 Then     'if only one cell selected force mAr to array
        ReDim mAr(1, 1)
        mAr(1, 1) = inRng.Value2
    Else
        mAr = inRng.Value2
    End If

    For i = 1 To allRows

       For Each itm In outArr   'remove all occurences of "itm"
         mAr(i, 1) = Replace(mAr(i, 1), itm, vbNullString, , , vbTextCompare)
       Next

       mAr(i, 1) = Replace(mAr(i, 1), "&", "AND")  'replace "&" with "AND"

       For Each itm In rsArr    'remove trailing "itm"
         sz1 = Len(itm)
         sz2 = Len(mAr(i, 1))
         If Right(mAr(i, 1), sz1) = itm Then mAr(i, 1) = Left(mAr(i, 1), sz2 - sz1)
       Next

       For Each itm In lsArr    'remove leading "itm"
         sz1 = Len(itm)
         sz2 = Len(mAr(i, 1))
         If Left(mAr(i, 1), Len(itm)) = itm Then mAr(i, 1) = Right(mAr(i, 1), sz2 - sz1)
       Next

    Next

    inRng = mAr                 'place memory array back to range
    MsgBox "Finished"

End Sub

Notlar:

• Daha kolay bakım için tüm kodlanmış değerleri alt kısımların üstündeki sabitlere taşıdım.

  (Sanırım birkaç tane ekledim - lütfen ihtiyacınız olmayanları kontrol edip kaldırın)