Excel VBA для стандартизации имен в выбранном диапазоне

Question

Я также новичок в обоих форумах Excel и пытаюсь собрать воедино код, который позволит пользователю обновить столбец текстовых записей. В основном то, что я пытался сделать, это:

предложить пользователю выбрать диапазон
начать с первой ячейки в диапазоне и обновить текст на основе кодировки.
заменить текст в этой ячейке на "чистый" текст
перейти к следующей ячейке в диапазоне сделать так же, как # 3
остановка в конце выбранного диапазона.

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

score 1 · Answer 1 · 2011-03-09T19:38:42

Этот код принимает выбор одной ячейки, вплоть до столбца смежных ячеек
Копирует диапазон в массив для эффективности
Выполняет все замены в размещенном вами коде в массиве
Помещает обновленный массив обратно в выбранный диапазон

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

Заметки:

Я переместил все жестко закодированные значения в константы в верхней части сабвуфера для облегчения обслуживания

(Я думаю, что я добавил пару из них - пожалуйста, проверьте и удалите те, которые вам не нужны)

Сейчас выбран русский

Excel VBA для стандартизации имен в выбранном диапазоне

1 ответ1

Всё ещё ищете ответ? Посмотрите другие вопросы с метками microsoft-excel vba find-and-replace range.

Excel VBA для стандартизации имен в выбранном диапазоне

1 ответ1

Всё ещё ищете ответ? Посмотрите другие вопросы с метками microsoft-excel vba find-and-replace range.

Похожие