Форум программистов
 
Регистрация на форуме тут, о проблемах пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail, а тут можно восстановить пароль

Купить рекламу на форуме 15-35 тыс рублей в месяц

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

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

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

На большом документе Word просто отрубился на 50 минуте, исходя и прочитанного текста макроса у меня возник вопрос, а как можно поставить диапазон обработки, то есть со страницы такой то по такую? Так как документ весь табличный и примерно половина его не требует такой обработки. Заранее прошу прощения за назойливость. Есть конечно выход из положения, взять требуемые страницы вставить в новый файл - обработать и вернуть в исходный, так, что если Вам будет сложно подсказать, то именно так и поступлю
Semen90 вне форума Ответить с цитированием
Старый 30.10.2009, 18:44   #12
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию Меняем три строчки кода и…

Думаю, что так должно работать. Выделите диапазон, в котором нужно обработать таблицы и вперед. Если всё же нужно по страницам, тоже несложно, но чуть позже. Бегу домой
Код:
Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oSelRng As Range 'Область из которой обрабатывать таблицы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oSelRng = Selection.Range 'Запоминаем диапазон выделения
  'Перебираем таблицы в выделении, начиная с конца
  For j = oSelRng.Tables.Count To 1 Step -1
    Set oTbl = oDocCurr.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 ' то ячейки удаляем
              oDocCurr.Save 'документ сохраняем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
  Next j
End Sub
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 30.10.2009, 18:52   #13
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Ну что ж Вы помогли мне опровергнуть песню следующего содержания - "Кто людям помогает, тот тратит время зря, хорошими делами прославиться нельзя...."
Semen90 вне форума Ответить с цитированием
Старый 30.10.2009, 23:54   #14
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Упс в данной интрепитации Word почему то покидает меня вплодь до перезагруза всего компа вцелом
Semen90 вне форума Ответить с цитированием
Старый 31.10.2009, 02:41   #15
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Виноват, переменную для документа убрал, а в теле макроса она осталась, а поскольку On Error Resume Next позволяет игнорировать ошибки, то Word и подвисал, пытаясь обратиться к содержимому несуществующей переменной.
Код:
Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oSelRng As Range 'Область из которой обрабатывать таблицы
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oSelRng = Selection.Range 'Запоминаем диапазон выделения
  'Перебираем таблицы в выделении, начиная с конца
  For j = oSelRng.Tables.Count To 1 Step -1
    Set oTbl = oSelRng.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 = oSelRange.Document.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
  Next j
End Sub
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 31.10.2009, 18:22   #16
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Как не странно но первый вариант оказался самы живучий, просто вырезаю нужный фрагмент для обработки вствляю в другой файл обрабатываю и возращаю на место
Semen90 вне форума Ответить с цитированием
Старый 31.10.2009, 18:29   #17
viter.alex
Балуюсь кодами
Участник клуба
 
Аватар для viter.alex
 
Регистрация: 09.01.2009
Сообщений: 1,837
По умолчанию

Совсем не странно, первый вариант я тестировал, а последующие — умозрительные, дома некогда тестировать: ребенок
Лучше день потерять — потом за пять минут долететь!©
viter.alex вне форума Ответить с цитированием
Старый 31.10.2009, 20:01   #18
Semen90
Пользователь
 
Регистрация: 29.10.2009
Сообщений: 12
По умолчанию

Удачи в воспитании
Semen90 вне форума Ответить с цитированием
Старый 05.11.2009, 00:15   #19
tolikman
Форумчанин
 
Регистрация: 25.08.2008
Сообщений: 159
По умолчанию

прошу удалить это сообщение, нечайно нажал на ентер...

Последний раз редактировалось tolikman; 05.11.2009 в 00:23. Причина: Ошибочное
tolikman вне форума Ответить с цитированием
Старый 05.11.2009, 00:23   #20
tolikman
Форумчанин
 
Регистрация: 25.08.2008
Сообщений: 159
По умолчанию

Попробуйте добавить к первому коду Viter.Alex'a процедуру "DoEvents":
Код:
.... первый вариант кода ....
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
    DoEvents
  Next j
End Sub
Это позволит Word'у после проверки каждой таблицы, говорить Вашей системе о том что его не заглючило, а для пущей комфортности прямо перед DoEvents можно добавить еще:
Код:
Application.StatusBar = "Обрботано: " & Cint((oDocCurr.Tables.Count - j)/oDocCurr.Tables.Count*100) & "%"
Вы будете знать сколько таблиц (в % от общего количества) обработано, отображаться будет в Worde в низу, в 2007 - по середине, в остальных версиях тоже где-то там же...
итого:
Код:
Sub DeleteEmptyRows()

  On Error Resume Next
  
  Dim oDocCurr As Document 'Рабочий документ
  Dim oTbl As Table 'Текущая таблица
  Dim oCell As Cell 'Ячейка в таблице
  Dim oRowRng As Range 'Диапазон для строки
  Dim iStart As Long 'Начало первой пустой ячейки в строке
  Dim iEnd As Long 'Конец последней пустой ячейки в строке
  Dim i As Long 'Счетчик строк в таблице
  Dim j As Long 'Счетчик таблиц
  Dim sEmptyString As String 'Служебная строка
  
  Set oDocCurr = ActiveDocument 'Запоминаем активный документ
  'Перебираем таблицы в документе, начиная с конца документа
  For j = oDocCurr.Tables.Count To 1 Step -1
    Set oTbl = oDocCurr.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 ' то ячейки удаляем
              oDocCurr.Save 'документ сохраняем
            End If
          End If
        Else: Err.Clear 'очищаем ошибку
        End If
      End If
    Next i
    Application.StatusBar = "Обрботано: " & Cint((oDocCurr.Tables.Count - j)/oDocCurr.Tables.Count*100) & "%" 
    DoEvents
  Next j
End Sub
Ну и если сильно захотеть можно рассчитать сколько осталось времени до завершения, приблизительно (особенно если таблицы едентичные).
Попробуй - вдруг поможет.

Последний раз редактировалось tolikman; 05.11.2009 в 00:27.
tolikman вне форума Ответить с цитированием
Ответ
Опции темы Поиск в этой теме
Поиск в этой теме:

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Добавление (удаление) строк в таблице 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