1 Тема от hill

  • hill
  • рядовой
  • Неактивен
  • Зарегистрирован: 02.08.2016
  • Сообщений: 1

Тема: Удаление части текста в таблице Word

Добрый день!

Есть огромная таблица в Word в которой в одном столбце в каждой из ячеек есть информация наподобие (просто текст везде разный):
слово или несколько слов
слово или несколько слов
*слово или несколько слов
*слово или несколько слов
слово или несколько слов*

Необходимо удалить из каждой ячейки тот текст, что находится после * или до * соответственно и оставить только строки без знака *.

В Excel получается убрать через замену * на другой символ, например на решетку и затем заменой сочетания решетки и звездочки (как любое количество символов) на пустое поле.

Возможно ли это сделать в Word?

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

Post's attachments

Пример.rtf 110.06 Кб, 6 скачиваний с 2016-08-02 

You don't have the permssions to download the attachments of this post.

2 Ответ от Fck_This

  • Удаление части текста в таблице Word
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97

Re: Удаление части текста в таблице Word

Добрый день. Для поиска звёздочки (*) используйте обратный слэш.
\*\(?\) этим можно убрать ваши пометки с цифрами в скобках.
Для удаления оставшихся после корректировки пробелов с запятой, можно воспользоваться данным кодом (В той темке человеку нужно было убрать конечный знак абзаца в ячейке):
Sub TablesRemovePilcrons()
Dim oTbl As Table
Dim oCll As Cell
For Each oTbl In ActiveDocument.Tables
   For Each oCll In oTbl.Range.Cells
      While oCll.Range.Characters.Last.Previous = Chr(13)
         oCll.Range.Characters.Last.Previous = ""
      Wend
   Next
Next
End Sub
С текстом нужно удалять макросом по параграфам сразу. Поиск и замена зависает когда вводишь то значение, которое выражает *+любое кол-во любых символов.

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

3 Ответ от Fck_This

  • Удаление части текста в таблице Word
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97

Re: Удаление части текста в таблице Word

Когда удалите цифры в скобках в первой строке, можно дальше удалять таким макросом (только до ума не довёл - не имел дела с выделением в ячейке - и потому он удаляет всю ячейку):
Sub áëèí()
Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "*"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Do
    With Selection
        If Not .Find.Execute Then Exit Do
        .MoveStartUntil ("*")
'        .StartOf Unit:=wdParagraph
        .MoveLeft Unit:=wdCharacter, Count:=1
        .EndOf Unit:=wdParagraph, Extend:=wdExtend
       
        .Delete
'        .EndKey Unit:=wdLine
    End With
Loop
End Sub

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871

4 Ответ от Fck_This

  • Удаление части текста в таблице Word
  • Fck_This
  • генерал-полковник
  • Неактивен
  • Откуда: Минск, Беларусь
  • Зарегистрирован: 13.07.2016
  • Сообщений: 648
  • Поблагодарили: 97

Re: Удаление части текста в таблице Word

Вот чего надумал. Цифры в скобках удаляются по старой схеме. А текст со звёздочкой убирал макросами. По мере слабых сил своих чего-то наваял и на данном участке текста срабатывает. Может кто-то оптимизирует. big_smile Было впадлу надумывать нового всего и замутил всё по шаблону. Кароч налетай-хохочи)

Sub SetParagraphCollapseStart()
' Если есть * в начале абзаца, то ставим в конце ячейки знак параграфа
Dim oTbl As Table
Dim oCll As Cell
Dim oPar As Paragraph
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.First = Chr(42) And oPar.Range.Characters.Last <> Chr(13) Then
            oCll.Range.Characters.Last = Chr(13)
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
End Sub

Sub SetParagraphCollapseEnd()
' Если есть * в конце абзаца, то ставим в конце ячейки знак параграфа
Dim oTbl As Table
Dim oCll As Cell
Dim oPar As Paragraph
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.Last.Previous = Chr(42) Then
            oCll.Range.Characters.Last = Chr(13)
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
End Sub

Sub Blinische()
' Blin Макрос
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
         With Selection.Find
        .Text = "\*[!^0013]@^0013"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub BlinischeInTheEnd()
' Blin Макрос
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
         With Selection.Find
        .Text = "[!^0013N]@\*^0013"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub VasyaTyPoputal()
Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
         With Selection.Find
        .Text = "\*\(?\)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub AraBratAraNeBratTyMne()
Dim oTbl As Table
Dim oCll As Cell
Dim oPar As Paragraph
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.Last.Previous = Chr(32) Then
            oCll.Range.Characters.Last.Previous = ""
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.Last.Previous = Chr(44) Then
            oCll.Range.Characters.Last.Previous = ""
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.Last.Previous = Chr(32) Then
            oCll.Range.Characters.Last.Previous = ""
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
For Each oTbl In ActiveDocument.Tables
    For Each oCll In oTbl.Range.Cells
        For Each oPar In oCll.Range.Paragraphs
            If oPar.Range.Characters.Last.Previous = Chr(44) Then
            oCll.Range.Characters.Last.Previous = ""
            Else:
            Message = "clear"
            End If
        Next
    Next
Next
End Sub

Запускать макросы в таком порядке, как тут. Ну а вообще можете слить всё в один по порядку. tongue

Спасибо можно перевести на WebMoney-кошелёк R378231864568 или на Яндекс-деньги 410015093172871