Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Word
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 03.04.2020, 18:26   #1
lamss
Новичок
Джуниор
 
Регистрация: 03.04.2020
Сообщений: 3
Восклицание Макрос ВИСЯЧИЕ ПРЕДЛОГИ

Помогите!
Данный макрос почему то виснет напрочь на таблицах и рисунках.
Можно ли переписать действие макроса, чтобы не зависал?

Sub ВисячиеПредлоги1()
Dim s$, n&
Selection.HomeKey Unit:=wdStory
Do
Selection.EndKey Unit:=wdLine
If Selection.End + 1 >= ActiveDocument.Range.End Then Exit Do
Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
s = Selection.Text
If s = vbCr Then 'пустой абзац, выделение сместилось на строку вверх!
Selection.MoveDown Unit:=wdLine, Count:=1
ElseIf LCase$(Right$(s, 2)) Like "[a-zа-яё] " And (Len(s) = 2 Or Len(s) = 3) Then
Selection.EndKey Unit:=wdLine
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.TypeText Text:=Chr(160) 'неразрывный пробел; происходит переход на сл. строку
n = n + 1
Selection.MoveUp Unit:=wdLine, Count:=1
End If
Selection.MoveDown Unit:=wdLine, Count:=1
Loop
MsgBox "Выполнено замен: " & n, vbInformation
End Sub
lamss вне форума Ответить с цитированием
Старый 18.04.2020, 07:22   #2
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Странный макрос. Если нужно заменить пробелы после предлогов на неразрынвный пробел, то достаточно поиска и замены:
Код:
With ActiveDocument.Range.Find
  .Text = "( [А-Яа-я]{1;3}) "
  .Replacement.Text = "\1^0160"
  .MatchWildcards = True
End With
ActiveDocument.Range.Find.Execute Replace:=wdReplaceAll
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 26.04.2020, 17:21   #3
lamss
Новичок
Джуниор
 
Регистрация: 03.04.2020
Сообщений: 3
По умолчанию

Нужно не просто заменить пробелы после предлогов на неразрывный пробел, а только у предлогов, которые (висячие) в конце строки.
lamss вне форума Ответить с цитированием
Старый 26.04.2020, 22:00   #4
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Ну если так, то попробуй такой вариант
Код:
Option Explicit

Sub FixOrphanePrep()
  Selection.HomeKey wdStory
  'Ищем предлоги — от одной до трёх букв, отделённых пробелами от остальных слов
  With Selection.Find
    .Text = "( [А-Яа-я]{1;3}) "
    .MatchWildcards = True
    While .Execute
      'Если найденное слово находится в конце строки
      If IsEndOfLine(.Parent.Range) Then
        'Последний символ (пробел) меняем на неразрывный пробел
        .Parent.Characters.Last.Text = ChrW(160)
        'Сворачиваем выделение, чтобы продолжить поиск
        Selection.Collapse wdCollapseEnd
      End If
    Wend
  End With
End Sub

' ----------------------------------------------------------------
' Procedure Name: IsEndOfLine
' Purpose: Определение, является ли диапазон концом строки
' Procedure Kind: Function
' Procedure Access: Public
' Parameter rng (Range): Заданный диапазон
' Return Type: Boolean
' Author: Viter Oleksandr
' Date: 26.04.2020
' ----------------------------------------------------------------
Function IsEndOfLine(rng As Range) As Boolean
  Dim lineNum, nextWordLineNum As Long
  Dim retval As Boolean
  Dim nextWord As Range
  Set nextWord = rng.Words.Last.Next(wdWord)
  'Номер строки, на которой находится заданный диапазон
  lineNum = rng.Characters(2).Information(wdFirstCharacterLineNumber)
  'Номер строки, на которой находится следующее слово
  nextWordLineNum = nextWord.Information(wdFirstCharacterLineNumber)
  
  retval = lineNum <> nextWordLineNum
  If retval Then
    Debug.Print "Line number: " & lineNum
    Debug.Print "Next word line number: " & nextWordLineNum
  End If
  IsEndOfLine = retval
End Function
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 27.04.2020, 12:49   #5
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Немного интерактивности
Код:
Sub FixOrphanePrep()
  Dim selStart As Long
  Application.ScreenUpdating = False
  selStart = Selection.Start
  Selection.HomeKey wdStory
  Dim counter As Integer
  'Ищем предлоги — от одной до трёх букв, отделённых пробелами от остальных слов
  With Selection.Find
    .Text = "( [А-Яа-я]{1;3}) "
    .MatchWildcards = True
    While .Execute
      'Если найденное слово находится в конце строки
      If IsEndOfLine(.Parent.Range) Then
        counter = counter + 1
        'Последний символ (пробел) меняем на неразрывный пробел
        .Parent.Characters.Last.Text = ChrW(160)
        'Сворачиваем выделение, чтобы продолжить поиск
        Selection.Collapse wdCollapseEnd
      End If
    Wend
  End With
  Range(selStart, selStart).Select
  MsgBox "Выполнено " & counter & " замен.", vbOKOnly + vbInformation, "Удаление висячих предлогов"
  Application.ScreenUpdating = True
End Sub
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 05.05.2020, 13:34   #6
alex4trd
Новичок
Джуниор
 
Регистрация: 05.05.2020
Сообщений: 1
По умолчанию Спасибо!

Здравствуйте, viter.alex!

Спасибо, все работает! Очень помог Ваш код!

Пока только начинаю разбираться с VBA.

Последний раз редактировалось alex4trd; 05.05.2020 в 13:43.
alex4trd вне форума Ответить с цитированием
Старый 11.05.2020, 14:09   #7
lamss
Новичок
Джуниор
 
Регистрация: 03.04.2020
Сообщений: 3
По умолчанию

viter.alex, спасибо! Первый работает, а у второго какая-то ошибка по-видимому.
lamss вне форума Ответить с цитированием
Старый 09.01.2022, 19:04   #8
4o_kavo
Новичок
Джуниор
 
Регистрация: 19.12.2016
Сообщений: 3
По умолчанию

Всем привет. Как применить данный код, может кто подсказать?
4o_kavo вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Висячие предлоги,как убрать? Alena029 Microsoft Office Word 14 31.03.2017 12:26
Макрос постоянно обрабатывает события. При открытии другой книги макрос обрывается. Ples Microsoft Office Excel 8 17.12.2016 18:15
Exel - при открытии файла через макрос, если файл отсутствует - виснет весь макрос gregory1b Microsoft Office Excel 2 14.10.2010 11:51
Макрос, запускающий макрос из другого закрытого файла petruha Microsoft Office Excel 7 14.03.2010 11:31
Макрос вставки файлов в листы-Необходимо изменить ниже приведённый макрос as-is Microsoft Office Excel 4 25.02.2010 07:51