Автор: Gena1971
Дата сообщения: 22.01.2014 23:14
bredonosec
Короче код очень сильно НЕоптимизирован, но на файле примера работает. Если в файлах будет как то по другому распознано, то могут быть ошибки, и естественно с ними и сохранит. Так что резерв надо обязательно оставить.
Я сделал замену в обоих ячейках...
[more=Вот, как то так...]
Код:
Sub Fix_tabl()
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
'.Filters.Add "All WORD File ", 1
.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
'----------------------
For Each Pol In ActiveDocument.Range.Paragraphs
.Text = "Pradiniai liku" 'Текст поиска
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If .Execute = True Then
Selection.MoveRight Unit:=wdCell 'Переход в следующую ячейку
Selection.MoveRight Unit:=wdCell
Selection.MoveLeft Unit:=wdCharacter, Count:=1 'Сброс выделения с позицией на начало
.MatchWildcards = True
.Text = " " 'Если все пробелы то " @"
.Replacement.Text = "^p" 'Строка замены на знак абзаца
'========== замена один раз пробелов на знак абзаца
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена пробелов
Selection.MoveRight Unit:=wdCharacter, Count:=1
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена пробелов
Selection.MoveRight Unit:=wdCharacter, Count:=1
.Replacement.Text = ""
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена пробелов
'========== ещё раз для следующей ячейки
Selection.MoveRight Unit:=wdCell
Selection.MoveLeft Unit:=wdCharacter, Count:=1 'Сброс выделения с позицией на начало
.MatchWildcards = True
.Text = " " 'Если все пробелы то " @"
.Replacement.Text = "^p" 'Строка замены на знак абзаца
'========== замена один раз пробелов на знак абзаца
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена пробелов
Selection.MoveRight Unit:=wdCharacter, Count:=1
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена пробелов
Selection.MoveRight Unit:=wdCharacter, Count:=1
.Replacement.Text = ""
.Execute 'Поиск пробелов
.Execute Replace:=wdReplaceOne 'Замена последнего пробелов
Else: Exit For
End If
Next Pol
End With
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "operation end, please view", vbInformation
End Sub
