在Excel VBA中基于数据库缩短单词

Question

I am currently trying to replace words in a cell with shorter versions in mass. I have a dictionary of words to make shorter and will have a column of cells that need to have one or more of the words shortened.

I am very new to VBA and I'm not sure how I would go about this. I tried searching and found some that would be changing text in a word doc but nothing from Excel to excel, at least with my search terms.

I have added a picture here of the Idea, the Text to be shortened is in column A, the words that can be shortened are in column C and the shortened versions are in column D.

Sample

Answer 1

You can use this UDF.

Function SubstituteMultiple(text As String, old_text As Range, new_text As Range)
Dim i As Single
For i = 1 To old_text.Cells.Count
Result = Replace(LCase(text), LCase(old_text.Cells(i)), LCase(new_text.Cells(i)))
text = Result
Next i
SubstituteMultiple = Result
End Function

Place this code in your regular module. then write this formula =SubstituteMultiple(A2,$C$2:$C$11,$D$2:$D$11) in cell B2 and drag it to the bottom.

Answer 2

Here's a full sub version if that works better for you

Sub ReplaceViaList()
Dim ws As Worksheet
Dim repRng As Range
Dim x As Long, lastRow As Long
Dim repCol As Long, oldCol As Long, newCol As Long
Dim oldStr As String, newStr As String

'screenupdating/calc
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'define worksheet
Set ws = ActiveSheet

'define columns to work with
repCol = 1 'col A
oldCol = 3 'col C
newCol = 4 'col D

'find last row of replacement terms
lastRow = ws.Cells(ws.Rows.Count, repCol).End(xlUp).Row

'set range of items to be replaced
Set repRng = ws.Range( _
    ws.Cells(2, repCol), _
    ws.Cells(lastRow, repCol) _
    )

'loop through cells in replacement terms
For x = 2 To ws.Cells(ws.Rows.Count, oldCol).End(xlUp).Row

    'define replacement terms
    oldStr = ws.Cells(x, oldCol).Value
    newStr = ws.Cells(x, newCol).Value

    'replace
    repRng.Replace What:=oldStr, Replacement:=newStr

Next x

'screenupdating/calc
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Answer 3

Perhaps simple replace in VBA would do it,

Sub test()
    Dim searchval As Variant
    Dim replaceval As Variant

    searchval = Range("C1:C10")
    replaceval = Range("D1:D10")

    For i = 1 To 10
        Columns("A:A").Replace What:=searchval(i, 1), Replacement:=replaceval(i, 1), LookAt:=xlPart
    Next i
End Sub