☰

Excel VBA zum Standardisieren von Namen in einem ausgewählten Bereich

tag-icon • tag-icon microsoft-excel vba find-and-replace range
Excel VBA zum Standardisieren von Namen in einem ausgewählten Bereich

Ich bin ein kompletter Neuling, sowohl in Excel als auch in diesen Foren, und versuche, Code zusammenzustellen, der es einem Benutzer ermöglicht, eine Spalte mit Texteinträgen zu aktualisieren. Im Grunde habe ich Folgendes versucht:

  1. fordert den Benutzer auf, den Bereich auszuwählen

  2. Beginnen Sie mit der ersten Zelle im Bereich und aktualisieren Sie den Text basierend auf der Codierung.

  3. Ersetzen Sie den Text in dieser Zelle durch den "sauberen" Text

  4. Gehen Sie zur nächsten Zelle im Bereich und machen Sie dasselbe wie Nr. 3.

  5. Am Ende des ausgewählten Bereichs stoppen.

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

Antwort1

  • Dieser Code akzeptiert die Auswahl einer Zelle bis hin zu einer Spalte zusammenhängender Zellen
  • Kopiert den Bereich aus Effizienzgründen in ein Array
  • Führt alle Ersetzungen in Ihrem geposteten Code im Array aus
  • Platziert das aktualisierte Array zurück im ausgewählten Bereich.
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

Anmerkungen:

  • Ich habe alle hartcodierten Werte in Konstanten oben im Sub verschoben, um die Wartung zu vereinfachen

    (Ich glaube, ich habe einige davon hinzugefügt – bitte überprüfen Sie sie und entfernen Sie die, die Sie nicht benötigen.)

verwandte Informationen