שאלה | חיפוש והחלפה בהרבה קבצי וורד ביחד

[ש. בר.]

האם אפשר להחליף מילה מסויימת בהרבה קבצי וורד ביחד?

[צבי 10]

@ש-בר אם אתה יודע מה זה VBA (תכנות ביישומי אופיס) אז כאן אולי יכול לעזור לך (סליחה שאין לי כח לעבור על זה כעת..)
או שיש פתרונות אחרים שאני לא מכיר. מסקנת הפוסט שם, מצורפת כאן.

Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
If TopLevelFolder = "" Then Exit Sub
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
End Sub
 
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub


Sub UpdateDocuments(oFolder As String)
Application.ScreenUpdating = False
Dim strInFolder As String, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = oFolder
strFile = Dir(strInFolder & "\*.docx", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFolder & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFolder & "\*.docx", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "["
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .Text = "]"
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .MatchWildcards = True
      .Text = "~*~"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
    End With
    'Save and close the document
    .SaveAs FileName:=strOutFold & .Name, AddToRecentFiles:=False
    .Close
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[ש. בר.]

@צבי-10
תודה על התגובה
לא יודע מה זה VBA
מה שצירפת אמור לעשות את מה שרציתי?

[צבי 10]

@ש-בר כן ולא.
כן אחרי שאתה לומד לעומק איפה להניח את הקבצים איך לקרוא להם וכו'
אולי מישהו ירצה לעזור לך - אני עמוס כרגע. (וגם לא משהו ב VBA)