replace单元格中的单词
我正在尝试创build一个简单的翻译脚本，它将从一个范围（列）中的每个单元格中查看一个句子，并根据我创build的简单的两列（lookat / replace）翻译记忆逐词翻译。
如果单元格包含
"This app is cool" 和翻译记忆是
This | 1 app | 2 cool | 3
结果应该是：
"1 2 is 3"
但是，使用.Replace方法，下面的string：
"This apple from the cooler"
会返回
"1 2le from the 3er"
我使用了一个数组和分裂的方法将这个句子分解成单词，然后从我的翻译列表中查找每个单词以进行xlwhole匹配。 我有大约1万行的句子，把每个句子分解成单词约为100,000个单词，每个单词翻译大约1000个翻译单词表。 它的话，但有点慢。
有没有其他方式，也许是一个更好的方法？
这是另一个使用replace方法和字边界的正则expression式解决scheme（正则expression式模式中的“\ b”表示一个字边界）。 它假设你的来源在A列，结果将进入B列。
macros表中的转换表是硬编码的，但是您可以轻松地将其从工作簿中的表格中更改。
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
救命的词：在这里，我利用Word的查找/replacefunction中的“仅匹配整个单词”选项。
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
另一种可能更快的方法是将所有句子一次性粘贴到Word文档中，replace所有内容，然后将所有内容一次性复制粘贴到Excel表格中。 这可能会更快; 我不知道，我没有广泛的testing， 由你来做。
为了实现这个， Set d = ...之后的行可以被replace为：
'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
如果你想要，你可以使用正则expression式 。
遵循该计划：
代码：
' 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
正则expression式很快，但是Word代码非常有趣（Copy＆Paste … 🙂