1

Тема: Удаление повторяющихся слов в начале каждой строки Word

Здравствуйте! Есть запись диалога в Ворде такого формата
Вася: бла-бла-бла
Вася:  бла-бла
Вася: бла
Петя: бла-бла
Петя: бла
Вася: бла-бла-бла

Необходимо удалить повторы имени в начале строки, если Вася или Петя кидают по несколько сообщений подряд, и свести в одну строку, то есть чтобы запись пришла к такому формату:
Вася: Бла-бла-бла бла-бла бла
Петя: бла-бла бла
Вася: бла-бла-бла

Как это сдлать с  помощью макроса?

2

Re: Удаление повторяющихся слов в начале каждой строки Word

Ivan1 пишет:

Как это сдлать с  помощью макроса?

Вот попробуйте (стартовый макрос MC_Scan)
'------------------------------------------------------------------------
Sub MC_Scan()
Dim numoflines As Long
Dim curname As String
Dim prevname As String
Dim curline As String
Dim curlinerg As range
Dim iline As Long
iline = 0
prevname = ""
numoflines = ActiveDocument.ComputeStatistics(wdStatisticLines)
If numoflines > 0 Then
    While (iline < numoflines)
        If iline = 0 Then
            Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst
        Else
            Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext
        End If
        Set curlinerg = GetSelectionCurlineRange()
        curline = Trim$(curlinerg.Text)
        curname = GetName(curline)
        If curname <> "" Then
            If prevname = curname Then
                CleanName curlinerg, curname
            End If
        End If
        iline = iline + 1
        prevname = curname
    Wend
End If
End Sub

Function GetSelectionCurlineRange() As range
Dim srg As range
Dim s1 As Long
Dim s2 As Long
s1 = Selection.range.Start
Selection.EndKey
s2 = Selection.range.End
Set srg = Selection.range
srg.SetRange Start:=s1, End:=s2
Selection.range.Start = s1
Set GetSelectionCurlineRange = srg
End Function

Sub CleanName(rgn As range, rnm As String)
Const namesep As String = ":"
Dim namerg As range
Set namerg = rgn
namerg.End = namerg.Start + Len(rnm) + Len(namesep)
namerg.Select
namerg.Delete
End Sub

Function GetName(line As String) As String
Dim curname As String
Const namesep As String = ":"
curname = Trim$(GetHead(line & " ", namesep))
If Len(curname) < 2 Then
    curname = ""
End If
GetName = curname
End Function

Public Function GetHead(ByVal input_line As String, ByVal sep_line As String) As String
Dim i_sep As Integer
Dim output_line As String
i_sep = InStr(input_line, sep_line)
If i_sep > 0 Then
   output_line = Mid$(input_line, 1, i_sep - 1)
Else
   output_line = ""
End If
GetHead = output_line
End Function

3

Re: Удаление повторяющихся слов в начале каждой строки Word

Спасибо! Работает!