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