Статьи из блога
Удаление лишних абзацев: очередной макрос
Владимир спрашивает:
Подскажите, что делать в такой ситуации. К примеру, копируем из какого-то другого приложения текст в Word. Зачастую потом приходится с помощью клавиши Delete (иногда в сочетании с пробелом) подтягивать текст, чтобы он нахоился как надо, а не обрывками на каждой строчке. Эту рутичнную работу в принципе можно автоматизировать с помощью Замены. Указать искать знак Конец абзаца и заменить на пустоту (подтянуть и пр.), но тогда в этом случае подтянутся не только строки. но и абзацы. Но абзацы должны оставаться абзацами.
Вот код макроса, который объединяет разорванные строки абзацев, не касаясь нормальных абзацев. Ничего выделять не нужно. Макрос сам определит разрывы в абзацах или отдельные абзацы (с точкой в конце), и от этого будет исполняться нужная часть кода.
Sub delPar()
Dim sPar As String
Dim par As Paragraph
Dim i As Integer
i = 0
For Each par In ActiveDocument.Paragraphs
If Right(par, 2) = Chr(46) & Chr(13) Then
i = i + 1
Else
If Right(par, 1) = Chr(13) Then
par.Range.Text = Replace(par.Range.Text, Chr(13), " ")
End If
End If
Next par
End Sub
Метки: лишние абзацы | макросы | форматирование
Просмотров: 39731
Подписаться на комментарии по RSS
Версия для печати
Еще записи по вопросам использования Microsoft Word:
- 10 вопросов и ответов по редактору Word (1 часть)
- 3 способа очистки списка недавно открытых документов
- Word 2007: добавляем свою вкладку и свои команды
- Word 2007: полотно, рисунки, линии
- Word 2007: смена формата сохранения файла
- Word 97 - решение проблемы с отображением символов на линейке
- Word 97. Слияние документов как один из способов упростить свою работу
- Абзац с цветным фоном
- Автозаполняемые колонтитулы
- Автоматизация текстового набора в Word
- Автоматическая запись макроса
- Автоматическая нумерация билетов
- Автоматическая расстановка переносов
- Автоматическое обновление полей при открытии документа
- Автоматическое сохранение документа при его закрытии
- Автотекст с последовательной нумерацией
- Автоформат документов
- Белый текст на синем фоне в Word 2007
- Буквица
- Быстрая смена ориентации страниц документа
- Быстрое изменение стиля форматирования текста
- Быстрое перемещение между открытыми документами Word
- Быстрое создание нового документа на основе шаблона
- Быстрое удаление границ у таблицы
- Быстрый ввод текста с помощью команды =rand()
Форум
Читают
Обсуждают
страницы
сайты
статистика
Комментариев: 18
Здравствуйте, Антон. Я не владею бейсиком, а этот макрос, который мне нужен, не хочет работать по причине "wrong number of arguments or invalid property assingment", выделяя при этом "Replace". Что не так?
Спасибо.
Чтобы это выяснить, нужно посмотреть ваш документ - текст. Какая версия редактора?
Ворд 2007 v.b.6.5 Я готов прислать скрин. На какой адрес?
Абзацы отделены пустыми строками? Если да, то можно предварительно заменить двойные знаки абзаца на ненужный символ, например $$.
Затем заменить двойные абзацы на одинарные.
После этого заменить $$ на знак абзаца.
Если абзацы тоже слиты, можно заменить знаки абзацев на $$. Затем с помощью подстановочных знаков заменить $$[а-я] на пробел. После этого восстановить абзацы – заменить $$ на знак абзаца.
Макрос конечно хорошо, но если его нет под руками, быстрее выполнить поиск и замену.
Также, помнится, пользовался спец. программой, которая конвертирует такой испорченный текст в нормальный. Название не помню.
А можно ли в этом макросе указать, чтобы изменеия производились только в абзацах, выделенных с помощью панели форматирования, т.е. имеющих одинаковый формат?
Напишите пожалуйста для чайников, как создать данный макрос через "сервис"! Очень нужно!
Спасибо.
Через «Сервис» этот макрос, если вы имеете ввиду макрос, предложенный Антоном, нельзя создать. Вернее можно, но только косвенно. Заходите в меню «Сервис»→«Макросы»→«Редактор Visual Basic» или просто нажимаете Alt+F11 и там вписываете этот код. Записать такой макрос через макрорекордер не получится.
а куда этот код вписывать
Если вы не знаете, как подключить к документу и применить эти макросы, изучите следующие заметки с сайта:
Создание макроса из готового кода
Автоматическая запись макроса
все я поняла
сначала открываем Visual Basic,потом в меню VIEW выбираем CODE, потом надо вставить нужную часть кода (она уже дана модераторами наверху в квадрате), потом в меню TOOLS выбираете Macros и нажимаете RUN. И все ваш док ГОТОВ. УРА. можно смело распечатывать
Лучше всего вывести кнопку этого макроса на панель инструментов в Word 2003 или на панель быстрого доступа в Word 2007. Как это можно сделать, описано на сайте. Используйте поиск вверху...
У вышеперечисленного макроса есть самый главный недостаток. Это просто адская медлительность. Если ваш текст занимает десятки страниц, то смело идите курить. А если сотни страниц, то ждать будете десятки минут.
Сам занялся задачей удаления лишних знаков абзацев в параграфах. Качал книги с lib.ru и исправлял текст примерно, как сказано у Сереги.
Потом стало лениво и решил написать макрос.
Получился примерно как в шапке и столкнулся с медлительностью. Поэтому написав пару разных вариантов, убыстряя алгоритм, остановился на том , который дам ниже.
Размер макроса несоизмеримо больше и намного сложнее вышеуказаного. Текст макроса подробно комментирован.
Назначение:
1) удаляет лишние знаки абзацев внутри текстовых (смысловых) абзацев
2) удаляет пустые абзацы
3) удаляет пробелы в начале абзацев
4) удаляет двойные пробелы
требования к тексту:
1) текстовые (смысловые) абзацы должны быть разделены пустыми строками или, как минимум, двумя пробелами в начале абзацев , т.е. красными строками
Преимущества:
1) работает максимально быстро.
Недостатки:
1) убирает форматирование текста (это сделано для сверхбыстрой работы)
сам макрос состоит из нескольких приватных функций и основной CleanEmptyPar.
Rem © Сачков Вадим Викторович. 20.11.2010 Sub CleanEmptyPar() Rem Макрос удаляет лишние знаки абзацев внутри смысловых абзацев. Rem Также удаляет пустые абзацы, красные строки и двойные пробелы. Rem ВНИМАНИЕ!!! Удаляется также форматирование текста Rem Для корректной работы макроса смысловые абзацы должны быть разделены пустой строкой Rem или красной строкой,состоящей, как минимум, из двух пробелов. Rem получает количество символов в обработанной строке. Dim rez As Long Rem строка, состоящая из всего обрабатываемого текста Dim str As String Rem сохранение всего текста из word в переменную в str str = ActiveDocument.Content.Text Rem каждая нижеследующая функция меняет содержимое str Rem удаление знаков chr(10) после chr(13) rez = DelChar10(str) Rem Удаление знаков абзацев внутри параграфов. rez = DelExcessPar(str) Rem Удаление пробелов в начале параграфов rez = DelSpaceInBeginPar(str) Rem Удаление пустых абзацев rez = DelEmptyPar(str) Rem Удаление двойных пробелов rez = DelDoubleSpace(str) Rem вывод обработанного текста обратно в Word ActiveDocument.Content.Text = str End Sub Private Function DelChar10(ByRef str As String) As Long Rem удаление знаков chr(10) после chr(13) Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String strnew = "" i = 1 j = 1 Do i = InStr(i, str, Chr(10)) If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If strnew = strnew & Mid(str, j, i - j) i = i + 1 j = i Loop str = strnew DelChar10 = Len(str) End Function Private Function DelExcessPar(ByRef str As String) As Long Rem Удаление знаков абзацев внутри параграфов. Rem Конец параграфа определяется или последующей пустой строкой, Rem или последующей красной строкой состоящей, как минимум, из двух пробелов Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String Rem строка состоящая из 2 пробелов для определения красной строки Dim strspace As String strspace = " " strnew = "" i = 0 If Mid(str, 1, 1) = Chr(13) Then i = i + 1 j = i + 1 Do i = InStr(i + 1, str, Chr(13)) If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If If Mid(str, i + 1, Len(strspace)) strspace Then If Mid(str, i - 1, 1) Chr(13) And Mid(str, i + 1, 1) Chr(13) Then strnew = strnew & Mid(str, j, i - j) & " " j = i + 1 End If End If Loop str = strnew DelExcessPar = Len(str) End Function Private Function DelSpaceInBeginPar(ByRef str As String) As Long Rem Удаление пробелов в начале параграфов, т.е. пробелы после знаков chr(13) Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String strnew = "" i = 1 j = 1 Do While (Mid(str, i, 1) = " ") i = i + 1 j = i Loop Do i = InStr(i, str, Chr(13)) If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If If Mid(str, i + 1, 1) = " " Then strnew = strnew & Mid(str, j, i - j + 1) i = i + 2 j = i Do While (Mid(str, i, 1) = " ") i = i + 1 j = i Loop Else i = i + 1 End If Loop str = strnew DelSpaceInBeginPar = Len(str) End Function Private Function DelEmptyPar(ByRef str As String) As Long Rem Удаление пустых абзацев Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String strnew = "" i = 1 j = 1 Do i = InStr(i, str, Chr(13)) If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If If Mid(str, i + 1, 1) = Chr(13) Then strnew = strnew & Mid(str, j, i - j + 1) i = i + 2 j = i Do If Mid(str, i, 1) = Chr(13) Then i = i + 1 j = i Else Exit Do End If Loop Else i = i + 1 End If Loop str = strnew DelEmptyPar = Len(str) End Function Private Function DelDoubleSpace(ByRef str As String) As Long Rem Удаление двойных пробелов Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String strnew = "" i = 1 j = 1 Do i = InStr(i, str, " ") If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If If Mid(str, i + 1, 1) = " " Then strnew = strnew & Mid(str, j, i - j + 1) i = i + 2 j = i Do If Mid(str, i, 1) = " " Then i = i + 1 j = i Else Exit Do End If Loop Else i = i + 1 End If Loop str = strnew DelDoubleSpace = Len(str) End Function Private Function AddChar10(ByRef str As String) As Long Rem возвращение знаков chr(10) после chr(13) Rem позиция в str найденной подстроки в тексте Dim i As Long Rem позиция в str, до которой изменненый текст сохранен в strnew Dim j As Long Rem строка для сохранения изменённого текста Dim strnew As String strnew = "" i = 1 j = 1 Do i = InStr(i, str, Chr(13)) If i = 0 Then strnew = strnew & Mid(str, j, Len(str) - j + 1) Exit Do End If If i = Len(str) Or Mid(str, i + 1, 1) Chr(10) Then strnew = strnew & Mid(str, j, i - j + 1) & Chr(10) i = i + 1 j = i Loop str = strnew AddChar10 = Len(str) End FunctionА куда эти макросы вставлять?
aluf613yeshururun@gmail.com
Спасибо!!!
Ребят, помогите. Макрос работает отлично, но есть одно "но". У меня в документах есть "шапка", которая редактируется вместе с остальным текстом. Как добавить эту шапку в исключения?
Спасибо. Только Ваш макрос и помог
Огромное спасибо! Все работает! Очень нужный макрос.
Код работает, но есть одно "но". Если в тексте присутствуют заголовки, например, названия разделов, которые не оканчиваются точкой, макрос сольет их с абзацем.
Я думал, как этого избежать, ничего кроме проверки регистра следующего за сомнительным знаком абзаца буквы не придумал...