替换单元格中的单词

Question

我正在尝试创建一个简单的翻译脚本，它将查看范围（列）中每个单元格中的一个句子，并根据简单的两列（lookat / replace）翻译记忆库逐字翻译。我创造了。

如果单元格包含

"This app is cool"

并且翻译记忆库是

This | 1
app  | 2
cool | 3

结果应该是：

"1 2 is 3"

但是，使用.Replace方法，以下字符串：

"This apple from the cooler"

会返回

"1 2le from the 3er"

我使用数组和拆分方法将句子分解为单词，然后查看我的翻译列表中的每个单词以进行xlwhole匹配。我有大约10,000行句子，并且将每个句子分解成单词大约大约100,000个单词，每个单词查看大约1,000个翻译单词列表。它的话......但有点慢。

还有其他方法，也许是更好的方法吗？

Answer 1

这是使用替换方法和字边界的另一个正则表达式解决方案（正则表达式中的＆＃34; \ b＆＃34;表示字边界）。它假定您的源位于A列，结果将进入B列。

转换表在宏中是硬编码的，但您可以轻松地将其更改为从工作簿中的表中选取。

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

拯救的话语：在这里我使用了＆＃34;仅匹配整个单词＆＃34; Word的查找/替换功能中的选项。

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文档中，替换所有内容，然后立即将所有内容复制粘贴回Excel工作表。它可能更快;我不知道，我还没有对它进行过广泛的测试;由你来做。

为了实现这一点，Set d = ...之后的行可以替换为：

'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

如果您需要，可以使用正则表达式 遵循该计划：

守则：

' 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

快速使用正则表达式，但Word代码非常有趣（复制和粘贴......： - ）