Статьи из блога

Удаление лишних абзацев: очередной макрос

Владимир спрашивает:

Подскажите, что делать в такой ситуации. К примеру, копируем из какого-то другого приложения текст в Word. Зачастую потом приходится с помощью клавиши Delete (иногда в сочетании с пробелом) подтягивать текст, чтобы он нахоился как надо, а не обрывками на каждой строчке. Эту рутичнную работу в принципе можно автоматизировать с помощью Замены. Указать искать знак Конец абзаца и заменить на пустоту (подтянуть и пр.), но тогда в этом случае подтянутся не только строки. но и абзацы. Но абзацы должны оставаться абзацами.

Вот код макроса, который объединяет разорванные строки абзацев, не касаясь нормальных абзацев. Ничего выделять не нужно. Макрос сам определит разрывы в абзацах или отдельные абзацы (с точкой в конце), и от этого будет исполняться нужная часть кода.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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

Рубрика: Стили и форматирование, Макросы, Вопрос-Ответ
Метки: | |
Просмотров: 39406
Подписаться на комментарии по RSS
Версия для печати

[Ссылки на статью]

twitter.com facebook.com vkontakte.ru odnoklassniki.ru mail.ru ya.ru rutvit.ru myspace.com technorati.com digg.com friendfeed.com pikabu.ru blogger.com liveinternet.ru livejournal.ru memori.ru google.com bobrdobr.ru mister-wong.ru yahoo.com yandex.ru del.icio.us

Еще записи по вопросам использования Microsoft Word:

Комментариев: 18

  1. Леонид
    23.12.2008 в 18:02 | #1

    Здравствуйте, Антон. Я не владею бейсиком, а этот макрос, который мне нужен, не хочет работать по причине "wrong number of arguments or invalid property assingment", выделяя при этом "Replace". Что не так?

    Спасибо.

  2. Админ
    23.12.2008 в 19:30 | #2

    Чтобы это выяснить, нужно посмотреть ваш документ - текст. Какая версия редактора?

  3. Леонид
    23.12.2008 в 20:36 | #3

    Ворд 2007 v.b.6.5 Я готов прислать скрин. На какой адрес?

  4. Серёга
    24.12.2008 в 13:05 | #4

    Абзацы отделены пустыми строками? Если да, то можно предварительно заменить двойные знаки абзаца на ненужный символ, например $$.

    Затем заменить двойные абзацы на одинарные.

    После этого заменить $$ на знак абзаца.

    Если абзацы тоже слиты, можно заменить знаки абзацев на $$. Затем с помощью подстановочных знаков заменить $$[а-я] на пробел. После этого восстановить абзацы – заменить $$ на знак абзаца.

    Макрос конечно хорошо, но если его нет под руками, быстрее выполнить поиск и замену.

    Также, помнится, пользовался спец. программой, которая конвертирует такой испорченный текст в нормальный. Название не помню.

  5. Игорь
    22.01.2009 в 18:12 | #5

    А можно ли в этом макросе указать, чтобы изменеия производились только в абзацах, выделенных с помощью панели форматирования, т.е. имеющих одинаковый формат?

  6. Александра
    01.03.2009 в 03:31 | #6

    Напишите пожалуйста для чайников, как создать данный макрос через "сервис"! Очень нужно! smile

    Спасибо.

  7. Александр Витер
    01.03.2009 в 14:07 | #7

    Через «Сервис» этот макрос, если вы имеете ввиду макрос, предложенный Антоном, нельзя создать. Вернее можно, но только косвенно. Заходите в меню «Сервис»→«Макросы»→«Редактор Visual Basic» или просто нажимаете Alt+F11 и там вписываете этот код. Записать такой макрос через макрорекордер не получится.

  8. powerrr
    09.08.2009 в 09:37 | #8

    а куда этот код вписывать

  9. Админ
    09.08.2009 в 09:40 | #9

    Если вы не знаете, как подключить к документу и применить эти макросы, изучите следующие заметки с сайта:

    Создание макроса из готового кода

    Автоматическая запись макроса

  10. powerrr
    09.08.2009 в 09:49 | #10

    все я поняла

    сначала открываем Visual Basic,потом в меню VIEW выбираем CODE, потом надо вставить нужную часть кода (она уже дана модераторами наверху в квадрате), потом в меню TOOLS выбираете Macros и нажимаете RUN. И все ваш док ГОТОВ. УРА. можно смело распечатывать

  11. Админ
    09.08.2009 в 09:53 | #11

    Лучше всего вывести кнопку этого макроса на панель инструментов в Word 2003 или на панель быстрого доступа в Word 2007. Как это можно сделать, описано на сайте. Используйте поиск вверху...

  12. Комментатор 63
    20.11.2010 в 23:01 | #12

    У вышеперечисленного макроса есть самый главный недостаток. Это просто адская медлительность. Если ваш текст занимает десятки страниц, то смело идите курить. А если сотни страниц, то ждать будете десятки минут.

    Сам занялся задачей удаления лишних знаков абзацев в параграфах. Качал книги с lib.ru и исправлял текст примерно, как сказано у Сереги.

    Потом стало лениво и решил написать макрос.

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

    Размер макроса несоизмеримо больше и намного сложнее вышеуказаного. Текст макроса подробно комментирован.

    Назначение:

    1) удаляет лишние знаки абзацев внутри текстовых (смысловых) абзацев

    2) удаляет пустые абзацы

    3) удаляет пробелы в начале абзацев

    4) удаляет двойные пробелы

    требования к тексту:

    1) текстовые (смысловые) абзацы должны быть разделены пустыми строками или, как минимум, двумя пробелами в начале абзацев , т.е. красными строками

    Преимущества:

    1) работает максимально быстро.

    Недостатки:

    1) убирает форматирование текста (это сделано для сверхбыстрой работы)

    сам макрос состоит из нескольких приватных функций и основной CleanEmptyPar.

  13. Комментатор 63
    22.11.2010 в 09:16 | #13

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    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

  14. Алексей
    23.10.2011 в 13:33 | #14

    А куда эти макросы вставлять?

    aluf613yeshururun@gmail.com

    Спасибо!!!

  15. Дмитрий
    17.11.2011 в 16:51 | #15

    Ребят, помогите. Макрос работает отлично, но есть одно "но". У меня в документах есть "шапка", которая редактируется вместе с остальным текстом. Как добавить эту шапку в исключения?

  16. Ольга
    01.11.2012 в 16:23 | #16

    Спасибо. Только Ваш макрос и помог

  17. Аноним
    13.10.2013 в 13:22 | #17

    Огромное спасибо! Все работает! Очень нужный макрос.

  18. Артем
    31.01.2014 в 00:55 | #18

    Код работает, но есть одно "но". Если в тексте присутствуют заголовки, например, названия разделов, которые не оканчиваются точкой, макрос сольет их с абзацем.

    Я думал, как этого избежать, ничего кроме проверки регистра следующего за сомнительным знаком абзаца буквы не придумал...

Оставьте комментарий!

(обязательно)

контакты

 
^ Наверх