Replace words in a cell - excel

Question

I'm trying to create a simple translation script that will look at a sentence in each cell from a range (column), and translate word by word based on the simple two-column (lookat/replace) translation memory I've created.
If the cell contains
"This app is cool"
and the translation memory is
This | 1
app | 2
cool | 3
Result should be:
"1 2 is 3"
However, using .Replace method, The below string:
"This apple from the cooler"
Would return
"1 2le from the 3er"
I used an array and split method to break the sentence into words, and then looked up at each words from my translation list for a xlwhole match. I have about 10,000 lines of sentences, and to break down each sentence into words would be roughly about 100,000 words and each word looking through about 1,000 list of translation words. It words.. but kind of slow.
Are there any other way, perhaps a better approach?

Answer 1

Here's another regex solution using the replace method and word boundaries (the "\b" in the regex pattern represents a word boundary). It assumes your source is in column A, and the results will go into column B.
The translation table is hard coded in the macro, but you could easily change that to be picked up from a table in your workbook.
Option Explicit
Sub Translate()
Dim V As Variant
Dim RE As Object
Dim arrTranslate As Variant
Dim I As Long, J As Long
Dim S As String
V = Range("a1", Cells(Rows.Count, "A").End(xlUp))
ReDim Preserve V(1 To UBound(V, 1), 1 To 2)
arrTranslate = VBA.Array(Array("This", 1), Array("app", 2), Array("cool", 3))
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = True
.ignorecase = True
End With
For I = 1 To UBound(V, 1)
S = V(I, 1)
For J = 0 To UBound(arrTranslate)
RE.Pattern = "\b" & arrTranslate(J)(0) & "\b"
S = RE.Replace(S, arrTranslate(J)(1))
Next J
V(I, 2) = S
Next I
Range(Cells(1, 1), Cells(UBound(V, 1), UBound(V, 2))) = V
End Sub

Answer 2

Word to the rescue: Here I make use of of the "Match whole words only" option in Word's Find/Replace functionality.
Dim rngSentences As Range
Dim sentences, translatedSentences, wordsToReplace, newStrings
Dim iWord As Long
Dim iSentence As Long
Dim cell As Range
Dim w As Word.Application
Dim d As Word.Document
Set rngSentences = Range("A1:A5")
wordsToReplace = Array("this", "app", "cool")
newStrings = Array("1", "2", "3")
Set w = New Word.Application
Set d = w.Documents.Add(DocumentType:=wdNewBlankDocument)
sentences = rngSentences.Value ' read sentences from sheet
ReDim translatedSentences(LBound(sentences, 1) To UBound(sentences, 1), _
LBound(sentences, 2) To UBound(sentences, 2))
For iSentence = LBound(sentences, 1) To UBound(sentences, 1)
'Put sentence in Word document
d.Range.Text = sentences(iSentence, 1)
'Replace the words
For iWord = LBound(wordsToReplace) To UBound(wordsToReplace)
d.Range.Find.Execute Findtext:=wordsToReplace(iWord), _
Replacewith:=newStrings(iWord), MatchWholeWord:=True
Next iWord
'Grab sentence back from Word doc
translatedSentences(iSentence, 1) = d.Range.Text
Next iSentence
'slap translated sentences onto sheet
rngSentences.Offset(0, 1) = translatedSentences
w.Quit savechanges:=False
Another, potentially faster alternative is to paste all your sentences into the Word doc at once, replace everything, then copy-paste everything back to Excel sheet at once. It may be faster; I don't know, I haven't tested it extensively; up to you to do so.
To implement this, the lines after Set d = ... can be replaced with this:
'Copy-paste all sentences into Word doc
rngSentences.Copy
d.Range.PasteSpecial DataType:=wdPasteText
'Replace words
For iWord = LBound(wordsToReplace) To UBound(wordsToReplace)
d.Range.Find.Execute Findtext:=wordsToReplace(iWord), Replacewith:=newStrings(iWord), _
MatchWholeWord:=True
Next iWord
'Copy-paste back to Excel sheet
d.Range.Copy
rngSentences.Offset(0, 1).PasteSpecial xlPasteValues
w.Quit savechanges:=False

Answer 3

If you want you can use Regex.
Following the Scheme:
The Code:
' reference: "Microsoft VBScript Regular Expressions 5.5"
Dim RegX As Object, Mats As Object, Counter As Long
Set RegX = CreateObject("VBScript.RegExp")
Dim TrA(1 To 1000) As String
Dim TrB(1 To 1000) As String
Dim TrMax As Integer
Dim StrSp
For i = 1 To 9999
If Range("D" & i).Value = "" Then Exit For
TrA(i) = Range("D" & i).Value
TrB(i) = Range("E" & i).Value
TrMax = i
Next
Range("B1:B10").ClearContents
For i = 1 To 9999
If Range("A" & i).Value = "" Then Exit For
With RegX
.Global = True
.Pattern = "[a-zA-Z0-9]+"
Set Mats = .Execute(Range("A" & i).Value)
End With
kk = Range("A" & i).Value
For Counter = 0 To Mats.Count - 1
For e = 1 To TrMax
If LCase(Mats(Counter)) = TrA(e) Then
kk = Replace(kk, Mats(Counter), TrB(e), , 1)
End If
Next
Next
Range("B" & i).Value = kk
Next
Set Mats = Nothing
Set RegX = Nothing
Regex it's quickly, but the Word code it's very interesting (Copy & Paste ... :-)