Замена текста в нескольких файлах Word

99
11

Я новичок в vba, и я пытался найти код для поиска и замены текста в нескольких файлах Word, которые находятся в разных подпапках в основной папке. Моя проблема в том, что когда я запускаю свой код, он, кажется, открывает каждый файл много раз, прежде чем переходить к следующему (или несколько циклов в одной и той же подпапке, прежде чем переходить к следующему); однако этого не происходит, когда я запускаю строку кода за строкой, которая действительно оставила меня в убытке; надеюсь, кто-то может дать некоторые ответы.

Sub DoLangesNow()
Dim file
Dim path As String
Dim StrFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim myStoryRange As Range

' Parent folder
StrFolder = "G:\Caminos de San Lorenzo II\"

' Loop through the subfolders
strSubFolder = Dir(StrFolder & "*", vbDirectory)

Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through files in subfolder
strFile = Dir(StrFolder & varItem & "\" & "*.doc")
Do While strFile <> ""
Set file = Documents.Open(FileName:=StrFolder & _varItem & "\" & strFile)
' Start of macro replace text x with y
For Each myStoryRange In ActiveDocument.StoryRanges
With myStoryRange.Find
.Text = "EDIFICIO CAPINURI"
.Replacement.Text = "CONJUNTO RESIDENCIAL LOS CAMINOS DE SAN LORENZO II"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "Olga Márquez"
.Replacement.Text = "Glady Rubiano"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "OLGA LEONOR MÁRQUEZ PAVA"
.Replacement.Text = "GLADY MOLINA RUBIANO"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "830.005.582-9"
.Replacement.Text = "830.065.826-7"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "Carrera 53 # 134 A - 71"
.Replacement.Text = "Calle 146 A # 58 B - 85"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "2588540"
.Replacement.Text = "6241551"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "313 4314549"
.Replacement.Text = "312 4680338"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = " 24149562"
.Replacement.Text = "0"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "capinuriph@gmail.com"
.Replacement.Text = "caminosdesanlorenzodos@gmail.com"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "Positiva"
.Replacement.Text = "Positiva"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = " ADMINISTRADORA"
.Replacement.Text = "ADMINISTRADORA"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next myStoryRange
' End of macro 1
' Saves the file
ActiveDocument.Save
ActiveDocument.Close , (SaveChanges)
' set file to next in Dir
strFile = Dir
Loop
Next varItem

End Sub

спросил(а) 2021-01-25T17:23:19+03:00 4 месяца, 3 недели назад
1
Решение
89

Таким образом, я закончил просмотр дополнительных сообщений в Интернете о поиске и замене слов в нескольких файлах/подпапках/папках и, наконец, закончил с этим, что, кажется, работает очень хорошо:

Sub DoLangesNow()
Dim file
Dim path As String
Dim StrFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
Dim myStoryRange As Range
Dim i As Long
Dim TargetList
Dim MyRange As Range
TargetList = Array("EDIFICIO CAPINURI", "Olga Márquez", "OLGA LEONOR MÁRQUEZ PAVA", "830.005.582-9", "Carrera 53 # 134 A - 71", "2588540", "313 4314549", "24149562", "capinuriph@gmail.com", "Positiva", "ADMINISTRADORA", "POSITIVA") ' put list of terms to find here
Dim sStringToAdd
sStringToAdd = Array("EDIFICIO TORRE 95", "Claudia Cárdenas", "CLAUDIA CARDENAS PEREZ", "959.011.545-0", "Calle 95 # 21 - 34", "-", "3043982237", "51798184", "aedyco@yahoo.com", "Positiva", "ADMINISTRADORA", "POSITIVA")

' Parent folder
StrFolder = "G:\Prueba\"

' Loop through the subfolders
strSubFolder = Dir(StrFolder & "*", vbDirectory)

Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
Debug.Print varItem
' Loop through files in subfolder
strFile = Dir(StrFolder & varItem & "\" & "*.doc")
Do While strFile <> ""
Debug.Print strFile
Set file = Documents.Open(FileName:=StrFolder & varItem & "\" & strFile)
' Start of macro replace text x with y

For i = 0 To UBound(TargetList)

Set MyRange = ActiveDocument.Content

MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
Replace:=wdReplaceAll

Set MyRange = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
Replace:=wdReplaceAll

Set MyRange = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range

MyRange.Find.Execute FindText:=TargetList(i), ReplaceWith:=sStringToAdd(i), _
Replace:=wdReplaceAll
Next i

' ' End of macro 1
' ' Saves the file
ActiveDocument.Save
ActiveDocument.Close
' set file to next in Dir
strFile = Dir
Loop
Next varItem
End Sub


Спасибо Синди Майстер за помощь!

ответил(а) 2021-01-25T17:23:19+03:00 4 месяца, 3 недели назад
45

Если вам нужно найти/заменить на одном документе, это не имеет большого значения. Однако, если вам нужно сделать это для всех документов Word в папке, это может быть очень большой проблемой. Нижеприведенный сценарий представляет собой пакетный процесс, который выполняет процедуру поиска/замены всех файлов Word в папке.

Sub FindReplaceAll()

Dim MyDialog As FileDialog, GetStr(1 To 100) As String
'100 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Marriott International" 'Find What
.Replacement.Text = "Marriott" 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation

End Sub

ответил(а) 2021-01-25T17:23:19+03:00 4 месяца, 3 недели назад
Ваш ответ
Введите минимум 50 символов
Чтобы , пожалуйста,
Выберите тему жалобы:

Другая проблема