macro za brisanje odredjenog teksta

Code:


' Returns paragraph index number which begins with given string in 'ParagraphBeginWith' if exists
Private Function ParagraphIsBeginWith(ByRef ThisParagraphs As Paragraphs, ParagraphBeginWith As String) As Long

    On Error Resume Next

    Dim r As Long
    Dim lLen As Long
    Dim xPar As Paragraph
    
    lLen = Len(ParagraphBeginWith)
    
    ' Return value
    ParagraphIsBeginWith = 0
    
    For Each xPar In ThisParagraphs
    
        ' Update counter
        r = r + 1
    
        ' If paragraph have text anywhere in paragraph
       'If InStr(xPar.Range.Text, ParagraphBeginWith) > 0 Then
       
           ' Return value
           'ParagraphIsBeginWith = r
           'Exit For
           
       'End If
       
       ' If paragraph begins with given text
       If Left(xPar.Range.Text, lLen) = ParagraphBeginWith Then

           ' Return value
           ParagraphIsBeginWith = r
           Exit For
       
       End If
    
    Next
    
    ' Free memory resource
    Set xPar = Nothing

    Err.Clear
    
End Function

Public Sub ParapgrahExtract()

    Dim xDoc As Document
    Dim i As Integer
    Dim sText As String
    Dim sTextBeginWith As String
    Dim sTextEndWith As String
    Dim lPar(1) As Long
    Dim Razlika As Long
    Dim bScrUp As Boolean
    
    On Error GoTo ErrHandler
    
    ' lPar(0..1)     -> Which paragraphs holds part of document which should be extracted and moved to new document
    ' 1 - 8          -> Paragraphs in document are header of document
    ' sTextBeginWith -> Paragraph which starts with <Tab> + 5. is beginning of document parth which should be extracted and moved to new document
    ' sTextEndWith   -> Paragraph which ends with <Tab> + 6. is part where extraction parts ends for document parth which should be extracted and moved to new document
    
    ' Save current setting of screen updating which is set
    bScrUp = Application.ScreenUpdating
    DoEvents
    
    ' Turn off live screen updating to get on speed
    Application.ScreenUpdating = False
    
    ' Create new document based on current active document - which will be used as working document
    Set xDoc = Application.Documents.Add(ActiveDocument.FullName)
    
    ' Make Document active
    xDoc.Activate
 
    ' Paragraph begin with pattern
    sTextBeginWith = vbTab & "5. "
    
    ' Paragraph which comes after paragraph which should be extracted
    sTextEndWith = vbTab & "6. "

    ' Get location of paragraph which begins with... --- this is set to be case senstive on lower and upper case letters; function code can be updated to be case insensitive
    lPar(0) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextBeginWith)
    
    ' Get location of paragraph which ends with... --- this is set to be case senstive on lower and upper case letters; function code can be updated to be case insensitive
    lPar(1) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextEndWith)
    
    ' If there is no ending paragraph which signals a end of extraction paragraph then set total count of paragraphs in document
    If lPar(1) = 0 Then lPar(1) = xDoc.Paragraphs.Count

    If lPar(0) > 0 Then
    
        Razlika = lPar(0) - 9
        
        Debug.Print Now, "lpar(0)", lPar(0)
        Debug.Print Now, "razlika", Razlika
        
        For i = 1 To Razlika

            ' Always delete paragraph 9 since we are reducing a number of paragraphs
            xDoc.Paragraphs(9).Range.Delete
        
        Next
        
        ' Since maybe we delete some paragraphs then we need to recalc locations
        
        ' Get location of paragraph which begins with...
        lPar(0) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextBeginWith)
        
        ' Get location of paragraph which ends with...
        lPar(1) = ParagraphIsBeginWith(xDoc.Paragraphs, sTextEndWith)
        If lPar(1) = 0 Then lPar(1) = xDoc.Paragraphs.Count
        
        Debug.Print Now, "after lpar(0)", lPar(0)
        Debug.Print Now, "after lpar(1)", lPar(1)
        Debug.Print Now, "after razlika", Razlika
        
        Razlika = xDoc.Paragraphs.Count - lPar(1)
        
        For i = 0 To Razlika
        
            ' Always delete paragraph which is the paragraph that signal the end of part of paragraph which should be extracted
            xDoc.Paragraphs(lPar(1)).Range.Delete
    
        Next
        
        
    End If
    
    ' Set back setting for screen updating which was set before
    Application.ScreenUpdating = bScrUp
    
    DoEvents
    
    Erase lPar
    
    ' Free memory resource
    Set xDoc = Nothing

Exit Sub
ErrHandler:
    ' Show message to user
    MsgBox "Doslo je do greske prilikom izvrsavanja koda." & vbCrLf & vbCrLf & "Greska # " & Err.Number & " - " & Err.Description, vbCritical, "ParapgrahExtract"
    Debug.Print Now, "Error #"; Err.Number, Err.Description
End Sub