none
Highlight the text replaced and put to lowercase this texte replaced RRS feed

  • Question

  • Hello,
    So I have a macro that searches for the word full-text or abbreviation and replaces it with the abbreviation (and put in brackets the word full-text) This macro is used for reliable research. We are looking for short or full text word, we find the record.
    I have firstly a highlighting problem with my macro: This macro actually highlights but once. Which means that once it has been executed once, it doesn't remakes the same for the next files.
    For the second problem, since my popular abbreviations are capitalized, the replacement text which takes the same format that the word and therefore appears capitalized. I would like the text replaced take the format of the Excel file.
    <textarea autocapitalize="off" autocomplete="off" autocorrect="off" class="goog-textarea" dir="ltr" id="contribute-target" name="edit-text" rows="1" spellcheck="false" style="height:auto;padding-right:20px;-ms-overflow-x:auto;-ms-overflow-y:hidden;box-sizing:border-box;" tabindex="0" wrap="SOFT"></textarea>
    Tuesday, September 29, 2015 11:46 AM

All replies

  • Sub Output()

    Dim oxlApp As Object ' Used for the Excel App
    Dim oxlWbk As Object ' Used for the Workbook
    Dim oxlSht As Object
    Dim FN As String
    Dim i As Integer
    Dim Text1 As String
    Dim Text2 As String
    Dim TextRepl As String
    Dim LastLine As Long

        Set oxlApp = CreateObject("Excel.Application")
        FN = "F:\Liste2.xlsx" ' Change this to the spreadsheet name you want.
        If FileExists(FN) Then ' Check to see if the spreadsheet exists.
            Set oxlWbk = oxlApp.Workbooks.Open(FileName:=FN) ' Open the Workbook
            Set oxlSht = oxlWbk.Worksheets(1)
            oxlWbk.Activate
            oxlSht.Activate
           
            LastLine = 200
           
                For i = 1 To LastLine
                   
                    Text1 = oxlSht.Cells(i, 1).Text
                    Text2 = oxlSht.Cells(i, 2).Text
                    TextRepl = oxlSht.Cells(i, 3).Text
                   
                       With ActiveDocument.Range.Find
                            .Text = Text1
                            .Replacement.Text = Text2
                            .Replacement.ClearFormatting
                            Selection.Find.Replacement.Highlight = True
                            .Forward = True
                            .Wrap = wdFindContinue
                            .Format = True
                            .MatchCase = False
                            .MatchWholeWord = True
                            .MatchWildcards = False
                            .MatchSoundsLike = False
                            .MatchAllWordForms = False
                            .Execute Replace:=wdReplaceAll
                       
                       With ActiveDocument.Range.Find
                            .Text = Text2
                            .Replacement.Text = TextRepl
                            '.Replacement.Text = StrConv(TextRepl, vbLowerCase)
                            .Replacement.Font.Outline = True
                            .Replacement.ClearFormatting
                            .Forward = True
                            .Wrap = wdFindContinue
                            .Format = True
                            .MatchCase = False
                            .MatchWholeWord = True
                            .MatchWildcards = False
                            .MatchSoundsLike = False
                            .MatchAllWordForms = False
                            .Execute Replace:=wdReplaceAll
                            Selection.Find.Replacement.Highlight = True

                        End With
                           
                        End With
                       
                Next
               
            oxlWbk.Close SaveChanges:=False ' Close the spreadsheet, saving the changes.
            Set oxlWbk = Nothing
        Else ' It does not exist so tell the user.
            MsgBox "Workbook " & FN & " not found"
        End If
        ' Close the Excel App cleanly
        oxlApp.Quit
        Set oxlApp = Nothing

    End Sub
    Function FileExists(FName As String) As Boolean
    ' Returns True if the file FName exists, else False
    Dim fs

        Set fs = CreateObject("Scripting.FileSystemObject")
        FileExists = fs.FileExists(FName)
        Set fs = Nothing
       
    End Function

    Tuesday, September 29, 2015 11:53 AM