Макрос для для замены слов в файле word из файла-словаря Excel

[Михаил_П]

Если речь идёт о Microsoft Office XP (или старше), то можно воспользоваться этим советом и замутить, что-то вроде :

Код: Выделить всё

With Application.FileDialog(msoFileDialogFolderPicker)
     If .Show = True Then
        iPath = .SelectedItems(1)
        iPath = IIf(Right(iPath, 1) = "\", iPath, iPath & "\")        
     Else
        MsgBox "Выберите нужную папку", vbCritical, ""
        Exit Sub
     End If
End With

Интересно, но почему-то макрос не исправляет всё содержимое колонтитулов. Что-то поправляет, что-то оставляет как есть))) Загадка...

[vans]

Друзья, добрый день. У меня такая же задача как и у автора. Можно ли объеснить как это использвать? Если можно как для тупых.

[pashulka]

1) Скачайте пример из поста #6
2) Составьте свой список автозамены
3) В макросе укажите свою папку
4) В макросе укажите расширение файлов (сейчас там только .doc) если есть шанс, что в папке могут наличествовать документы различных версий, например и .docx, то "замените" "*.doc" на "*.doc*"
5) Кликните кнопку Замена в файлах .doc

P.S. Повторюсь, но тестировать лучше на копиях документах, ибо отката(отмены действий макроса) уже не будет.

[KapitanFracas]

Здравствуйте скачал пример. Спасибо автору.

Подскажите пожалуйста почему при попытке запуска макроса:

Private Sub Test()

Dim iPath$, iFileName$, iText$
Dim iCount&, iCounter&, iArrText As Variant
Dim iWordApp As Object, iWordDoc As Object

iPath = "C:\Users\pc\Desktop\CHINESE TRANSLATIONS"
iFileName = Dir(iPath & "*.doc*")

If iFileName <> "" Then
With Range(Cells(2, "A"), Cells(Rows.Count, "B").End(xlUp))
iArrText = .Value: iCount = UBound(iArrText)
End With

Set iWordApp = CreateObject("Word.Application")
iWordApp.Visible = False
'iWordApp.DisplayAlerts = 0 'wdAlertsNone

Do
Set iWordDoc = iWordApp.Documents.Open(iPath & iFileName)

With iWordDoc.Content.Find
For iCounter = 1 To iCount
.Execute FindText:=iArrText(iCounter, 1), _
ReplaceWith:=iArrText(iCounter, 2), Replace:=2 'wdReplaceAll
Next
End With

iFileName = Dir: iWordDoc.Close -1 'wdSaveChanges
Loop Until iFileName = ""

iWordApp.Quit
Else
MsgBox "files with extension .doc not found", vbCritical, ""
End If
.............................................................

макрос сразу перескакивает в предупреждение

Else
MsgBox "files with extension .doc not found", vbCritical, ""
End If

то есть не находит ни одного файла с расширением "*.doc*"?

Спасибо

[pashulka]

Не было в моём примере предупреждения на буржуйском языке

Зато было написано, цитирую

Код: Выделить всё

iPath = "C:\Test\" 'укажите свою папку с завершающим слэшем

А где у Вас слэш после CHINESE TRANSLATIONS ?

[KapitanFracas]

спасибо большое, если смогу запустить с меня бутыль буржуйского

[KapitanFracas]

нет не удалось

................
Private Sub Test()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
iPath = .SelectedItems(1)
iPath = IIf(Right(iPath, 1) = "\", iPath, iPath & "\")
Else
MsgBox "§£§í§Ò§Ö§â§Ú§ä§Ö §ß§å§Ø§ß§å§ð §á§Ñ§á§Ü§å", vbCritical, ""
Exit Sub
End If
End With

If iFileName <> "" Then
With Range(Cells(2, "A"), Cells(Rows.Count, "B").End(xlUp))
iArrText = .Value: iCount = UBound(iArrText)
End With

Set iWordApp = CreateObject("Word.Application")
iWordApp.Visible = False
'iWordApp.DisplayAlerts = 0 'wdAlertsNone

Do
Set iWordDoc = iWordApp.Documents.Open(iPath & iFileName)

With iWordDoc.Content.Find
For iCounter = 1 To iCount
.Execute FindText:=iArrText(iCounter, 1), _
ReplaceWith:=iArrText(iCounter, 2), Replace:=2 'wdReplaceAll
Next
End With

iFileName = Dir: iWordDoc.Close -1 'wdSaveChanges
Loop Until iFileName = ""

iWordApp.Quit
Else
MsgBox "files with extension .doc not found", vbCritical, ""
End If

End Sub
.................

Выбор фолдера запускается, выбираю фолдер, сразу идет сообщение что файл не найден.

Пашулька а может оставите способ связи? договоримся.

[pashulka]

Достаточно просто добавить слэш, т.е.

Код: Выделить всё

iPath = "C:\Users\pc\Desktop\CHINESE TRANSLATIONS\"

Если же нужен диалог выбора папки, то не нужно выкидывать из авторской версии важные моменты. Проще говоря, должно быть так :

Код: Выделить всё

End With

iFileName = Dir(iPath & "*.doc*")

If iFileName <> "" Then

И не стоит забывать, что в этом примере функция Dir будет игнорировать файлы с атрибутами Скрытый и/или Только для чтения. Если же это неприемлемо, то здесь в Example2 есть решение.

[KapitanFracas]

Спасибо, сделал, теперь диалог открывается но выдается ошибка 5151

Pashulka a давайте еще упростим задачу? Исходник был написан для множественных файлов в выбранной папке. Но мне нужен один файл, не подскажете какой диалог лучше для выбора одного файла? Я диалог отлажу отдельно а потом перейдем к замене. Спасиб

[pashulka]

Один из возможных вариантов :

Код: Выделить всё

Dim iFileName As Variant
iFileName = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
   
If iFileName <> False Then
   MsgBox iFileName, , ""
Else
   MsgBox "Надо было выбрать документ", vbCritical, ""
End If