(求助) 英式英语词汇替换美式英语词汇

666611430 · 发表于 2020-12-12 11:27

谢谢网友提出的方
*我也是编程爱好者，平时比较多与C#打交道，本来用C#来处理此贴问题，但后来想用VBA处理，可我不懂VBA，才发此帖请求老师们出手帮忙，我一旦有了VBA比较符合文本处理（其实此贴本身就是属于文本处理范畴），我就能将VBAb用C#写出来。我依然期盼老师们早点出手帮忙。
--------------
*网友，说的很对，先把单词列表（本贴单词是多列的）读取到缓冲区域，临时保存，这样避免每次读取txt，保存到缓冲区域可以可以反复读取，只要程序不被关闭，程序读取的始终是缓冲区域的单词列表。
*谢谢网友关注
----------------------------------------
再一次顶贴，希望老师给点比较完美的代码。

413191246se · 发表于 2020-12-12 22:22

wdpfox：如确实需要，请提供一下模拟附件（包括各个要素）。

wdpfox · 发表于 2020-12-13 16:57

本帖最后由 wdpfox 于 2020-12-14 11:17 编辑

413191246se 发表于 2020-12-12 22:22
wdpfox：如确实需要，请提供一下模拟附件（包括各个要素）。

我只是想学习，感兴趣而已，明天单位发个附件。

English.rar (300.84 KB, 下载次数: 14)

413191246se · 发表于 2020-12-14 22:33

wdpfox：我的天！5个文档是一样的，而且没有词汇表。怎么查找？

wdpfox · 发表于 2020-12-15 07:30

词汇表用一楼的，文件内容一样只是为验证代码

413191246se · 发表于 2020-12-16 00:57

* 第 4 行代码：当 s=1 时，英式转美式 / 当 s=2 时，美式转英式（可自行修改，仅限 1/2 两个值）
* 为自己方便（因为我用的是 Win10-64位系统，汉字直接拷贝到帖子会变成乱码，所以全用英文字符）

Sub aaaa_UK2US()
If Documents.Count = 0 Then MsgBox "Please open the text file - variants.txt!", 0 + 16: End
If ActiveDocument.Name <> "variants.txt" Then MsgBox "Please open the text file - variants.txt!", 0 + 16: End
Const s As Long = 1 '(1=UK2US/2=US2UK)
Dim arr, brr, i&, y$
'arr
ActiveDocument.Content.Find.Execute "^9*(^13)", , , 1, , , , , , "\1", 2
ActiveDocument.Paragraphs.Last.Range.Delete
arr = Split(ActiveDocument.Content.Text, vbCr)
'brr
y = ActiveDocument.FullName
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Documents.Open FileName:=y
ActiveDocument.Content.Find.Execute "<*^9(*^13)", , , 1, , , , , , "\1", 2
ActiveDocument.Paragraphs.Last.Range.Delete
brr = Split(ActiveDocument.Content.Text, vbCr)
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
'replace
Dim pPath$, f As Object, fd As Object, fso As Object, Stack$(), top&, n&, stxt$, doc As Document, x&
pPath = MySelectFolder
Set fso = CreateObject("Scripting.FileSystemObject")
top = 1
ReDim Stack(0 To top)
Do While top >= 1
For Each f In fso.getfolder(pPath).Files
n = n + 1
stxt = f.Path
If stxt Like "*.doc*" Then
Set doc = Documents.Open(FileName:=stxt)
'-----------------------------------------------------------
For i = 0 To UBound(arr) - 1
With Selection
.HomeKey 6
With .Find
.ClearFormatting
If s = 1 Then
.Text = arr(i)
.Replacement.Text = brr(i)
Else
.Text = brr(i)
.Replacement.Text = arr(i)
End If
.Forward = True
.MatchWildcards = False
.MatchWholeWord = True
Do While .Execute
With .Parent
With .Font
.Color = wdColorRed
.Underline = wdUnderlineSingle
End With
.Start = .End
End With
Loop
End With
End With
Next
'------------------------------------------------------------
doc.Close SaveChanges:=wdSaveChanges
x = x + 1
End If
Next
For Each fd In fso.getfolder(pPath).SubFolders
Stack(top) = fd.Path
top = top + 1
If top > UBound(Stack) Then ReDim Preserve Stack(0 To top)
Next
If top > 0 Then pPath = Stack(top - 1): top = top - 1
Loop
Set f = Nothing
Set fd = Nothing
Set fso = Nothing
MsgBox "Total files = " & n & vbCr & "Word Files(*.docx/*.doc) = " & x, 0 + 48
End Sub

复制代码

666611430 · 发表于 2021-1-2 19:52

网友，你在16的代码是写给本贴的还是？如果不是再一次顶贴

413191246se · 发表于 2021-1-2 22:36

楼主，16楼代码是写给 wdpfox 朋友的。

666611430 · 发表于 2021-1-9 11:43

顶贴，求助中，，，，

sylun · 发表于 2021-1-20 22:42

可试试如下代码。仅针对一个文档，未提供选择。
在我的win10 和Office 2019环境下测试，正则部分的代码运行超慢，而在WPS下运行正常，两者速度相差可超100倍，未知原因。另外，代码在WPS下运行，不能实现单词相应的大小写格式替换，需改变思路另行转换。

Sub test()
'英式与美式英语单词替换
Dim fso, f
Dim myRegExp, myMatches, myMatch
Dim c As Integer
Dim i As Integer
Dim n As Integer
Dim sum As Integer
Dim txt As String
Dim data() As String '对照表文件词条数据
Dim data2() As String '有实例词条的匹配信息
Dim info() As String '词条对照表数据
Dim info2() As String '实际查找替换数据
Dim st As Single
st = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("d:\临时\variants.txt", 1) '自行指定词汇文件地址
data = Split(f.Readall, vbCrLf)
f.Close
c = UBound(data)
ReDim info(1, c)
For i = 0 To c
info(0, i) = Split(data(i), vbTab)(0)
info(1, i) = Split(data(i), vbTab)(1)
Next
txt = ActiveDocument.Content.Text
Set myRegExp = CreateObject("VBScript.RegExp")
For i = 0 To c
With myRegExp
.Pattern = "\b" & info(0, i) & "\b"
.Global = True
.Ignorecase = True
Set myMatches = .Execute(txt)
If myMatches.Count > 0 Then
sum = sum + myMatches.Count
ReDim Preserve info2(1, n)
info2(0, n) = info(0, i)
info2(1, n) = info(1, i)
ReDim Preserve data2(n)
data2(n) = n + 1 & vbTab & info(0, i) & vbTab & myMatches.Count & vbTab & info(1, i)
n = n + 1
End If
End With
Next
Options.DefaultHighlightColorIndex = wdYellow
Application.ScreenUpdating = False
For i = 0 To UBound(info2, 2)
With ActiveDocument.Content.Find
.Text = info2(0, i)
.Replacement.Text = info2(1, i)
.Replacement.Highlight = True
.MatchWholeWord = True
.Execute Replace:=wdReplaceAll
End With
Next
With Documents.Add '新文档输出处理信息
.Content.Text = "共找到" & UBound(data2) + 1 & "个词汇，" & sum & "处，用时" & Round(Timer - st, 2) & "秒。内容见下表：" & vbCrLf _
& "序号" & vbTab & "匹配词" & vbTab & "匹配数" & vbTab & "替换的词" & vbCrLf & Join(data2, vbCrLf)
.Range(.Paragraphs(2).Range.Start, .Range.End).ConvertToTable.Borders.Enable = True
.Tables(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] (求助) 英式英语词汇替换美式英语词汇

评分