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

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

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

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

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

Ответ
 
Опции темы Поиск в этой теме
Старый 05.11.2009, 01:25   #21
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Запустил тестировать так же на большом документе, но не уверен за результат, так старый ворд полетел, а тот, что сейчас установлен, как то не адекватно установился. Завтра точне сегодня после обеда смогу сказать точно как работает макрос на больших объемах
Semen90 вне форума Ответить с цитированием
Старый 05.11.2009, 03:41   #22
tolikman
Форумчанин
 
Регистрация: 25.08.2008
Сообщений: 159
По умолчанию

Работоспособность макросов редко нарушается после неудачной инсталяции офиса, обычно накрывается пользовательский интерфейс.
tolikman вне форума Ответить с цитированием
Старый 05.11.2009, 19:45   #23
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Спасибо! Удачное решение, а то и не знаешь толи висит толи работает
И все таки так и остался вопрос по поводу диапазона обработки как указать диапазон в страницах, с выделением как выяснилось работает не очень удачно. Извените за назойливость
Semen90 вне форума Ответить с цитированием
Старый 05.11.2009, 20:51   #24
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Попробуй такой вариант. Внёс изменения, которые предложил tolikman. Пользователю предлагается указать номера страниц, на которых обрабатывать таблицы. Код без подсветки потому, что иначе не влезет в сообщение.
Код:
Private Declare Function GetTickCount Lib "kernel32" () As Long

Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oDocCurr As Document 'Рабочий документ
  Dim oSrchRng As Range 'Диапазон, в котором искать страницы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim nTblsCount 'Количество таблиц в диапазоне
  Dim nStartPage As Long, nEndPage As Long 'Номер первой и последней страницы, которые нужно просматривать
  Dim nDocPagesCount 'количество страниц в документе
  Dim sInputStr As String 'Строка для ввода номеров страниц
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim StartTime As Long 'Таймер
  Dim sEmptyString As String 'Служебная строка
  
  Set oDocCurr = ActiveDocument 'Запоминаем активный документ
  nDocPagesCount = oDocCurr.Range.ComputeStatistics(wdStatisticPages)
  'Запрос номеров страниц
  sInputStr = InputBox("Укажите диапазон страниц, в котором обрабатывать таблицы", "Удаление пустых строк", _
                    "1-" & nDocPagesCount)
  
  If Len(sInputStr) <> 0 Then
    'Извлекаем номера страниц из строки
    nStartPage = CLng(Mid(sInputStr, 1, InStr(sInputStr, "-") - 1))
    nEndPage = CLng(Mid(sInputStr, InStr(sInputStr, "-") + 1))
  Else: Exit Sub
  End If
  'Если номер начальной страницы меньше единицы, или номер конечной страницы больше количества _
  страниц в документе или равен нулю, или номер начальной страницы больше номера конечной, то прекращаем выполнение макроса
  If nStartPage < 1 Or _
     nEndPage > nDocPagesCount Or _
     nStartPage > nEndPage or _
     nednThen
    Exit Sub
  End If
  
  'Запоминаем диапазон нужных страниц
  Set oSrchRng = oDocCurr.Range.GoTo(wdGoToPage, wdGoToAbsolute, nStartPage)
  oSrchRng.SetRange oSrchRng.Start, oDocCurr.Range.GoTo(wdGoToPage, wdGoToAbsolute, nEndPage + 1).Start
  
  nTblsCount = oSrchRng.Tables.Count
  
  StartTime = GetTickCount 'Запоминаем момент начала цикла
  'Перебираем таблицы в документе, начиная с конца документа
  For j = nTblsCount To 1 Step -1
    Set oTbl = oSrchRng.Tables(j) 'Запоминаем таблицу
    'Перебираем ячейки в первом столбце
    For i = oTbl.Rows.Count To 1 Step -1
      If Len(oTbl.Cell(i, 1).Range.Text) = 2 Then 'Если ячейка пустая, т.е. содержит только конец абзаца и конец ячейки
        If Err.Number <> 5941 Then 'Если такая ячейка существует
          Set oCell = oTbl.Cell(i, 1) 'Запоминаем первую ячейку в строке
          If Not oCell Is Nothing Then 'Если ячейка запомниалась
            iStart = oCell.Range.Start 'Запоминаем ее начало
            Do While Len(oCell.Next.Range.Text) = 2 'Теперь ищем последнюю пустую ячейку в этой же строке
              iEnd = oCell.Next.Range.End 'Запоминаем ее конец
              Set oCell = oCell.Next
            Loop
            Set oRowRng = oDocCurr.Range(iStart, iEnd) 'Запоминаем диапазон от начала первой пустой ячейки до конца последней
            'Удаляем из строки знаки абзаца и конца ячейки
            sEmptyString = Replace(oRowRng.Text, ChrW(13) & ChrW(7), "")
            If Len(sEmptyString) = 0 Then 'Если строка пустая,
              oRowRng.Cells.Delete ' то ячейки удаляем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку, если ячейки не было
        End If
      End If
    Next i 'конец цикла перебора строк
    Application.StatusBar = "Обработано " & nTblsCount - j + 1 & " таблиц. Прошло " & FormatNumber((StartTime - GetTickCount) / 1000, 1, groupdigits:=vbTrue) & " сек."
    DoEvents
  Next j 'конец цикла перебора таблиц
End Sub
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 14.07.2022, 12:28   #25
drosselino
Новичок
Джуниор
 
Регистрация: 14.07.2022
Сообщений: 1
По умолчанию

Всем привет! Огромное спасибо за тему. У меня не все работает стабильно, но один из кодов удалось "оптимизировать" под свои нужды). Но есть проблема. Подскажите, пожауйста, как поправить код, чтобы макрос не удалял пустые ячейки в начале строки? Дело в том, что он не понимает, что строка не закончилась и удаляет эти ячейки (см. приложенный скрин).
С полностью пустыми строками проблем нет - сносит базжалостно.
Заранее спасибо
https://dropmefiles.com/hXGy4
Изображения
Тип файла: jpg Screenshot_14.jpg (67.9 Кб, 15 просмотров)
drosselino вне форума Ответить с цитированием
Ответ


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

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Добавление (удаление) строк в таблице inside9 Microsoft Office Excel 29 01.01.2012 22:31
Матрица: добавление пустых строк Romer9999 Паскаль, Turbo Pascal, PascalABC.NET 4 09.12.2008 12:14
Вставка пустых строк в FastReport'е Boatswain БД в Delphi 1 13.11.2008 14:41
Автоматическое изменение количества строк в таблице THE_ENGINEER Microsoft Office Excel 7 19.10.2008 21:28