Tekst veranderen naar superscript

[linkav]

Beste,

Ik zou een macro willen maken waarbij ik een tekst doorloop op zoek naar '1ste' en deze tekst zou vervangen moeten worden door '1' en in superscript 'ste'.

Kan iemand mij verder helpen? Kan dit met een zoek en vervang?

Alvast bedankt voor de hulp!

 

[JanBG]

Hallo,

Daar heb je geen macro voor nodig, kun je gewoon instellen in Word.

Bestand --> opties --> autocorrectie opties --> Auto opmaak --> rangtelwoorden

 

[OctaFish]

En als je een document hebt waarin het al 'verkeerd' staat, kun je het gewoon met Zoeken en Vervangen doen. Ook geen macro nodig .

 

[linkav]

Dag allemaal,

Bedankt voor jullie reacties.

Het gaat eigenlijk om 'platte' tekst uit een tekstbestand dat gekopieerd wordt in Word en hier dan geformateerd moet worden. Hiervoor is al een macro die bepaalde zaken doet: dubbele spaties eruit halen, na ieder leesteken wordt een spatie gezet, na een punt wordt begonnen met een hoofdletter, .... Het gaat om Word documenten van 150 tot 25 pagina's. Een uitbreiding van de macro is de karakters die na een getal staan moeten in superscript komen. Als de autocorrectie aan staat in Word, wordt tijdens het typen de tekst gewijzigd maar niet wanneer er tekst in een Word document gekopieerd wordt.

Maar ondertussen heb ik het zelf al gevonden:

Public Sub macrAricKluwerSuperScript()
On Error GoTo err_Handling
    Dim tmpArrSupScrNumbMin     As Long
    Dim tmpArrSupScrNumbMax     As Long
    Dim tmdIndSupScrNumb        As Long
    
    Dim tmpArrSupScrTxtMin      As Long
    Dim tmpArrSupScrTxtMax      As Long
    Dim tmdIndSupScrTxt         As Long
    
    Dim tmpInd                  As Long
    
    Dim tmpStrFind              As String
    
    Call fnctAricKluwerSuperScriptsSetArrays
        
    tmpArrSupScrNumbMin = LBound(glblArrSupScrNumbers)
    tmpArrSupScrNumbMax = UBound(glblArrSupScrNumbers)
    
    tmpArrSupScrTxtMin = LBound(glblArrSupScrTexts)
    tmpArrSupScrTxtMax = UBound(glblArrSupScrTexts)
    
    Application.ScreenUpdating = False
        For tmdIndSupScrTxt = tmpArrSupScrTxtMin To tmpArrSupScrTxtMax
            For tmdIndSupScrNumb = tmpArrSupScrNumbMin To tmpArrSupScrNumbMax
                tmpStrFind = glblArrSupScrNumbers(tmdIndSupScrNumb) & glblArrSupScrTexts(tmdIndSupScrTxt)
                
                With ActiveDocument.Range
                    With .Find
                        .ClearFormatting
                        .Replacement.ClearFormatting
                        .Text = tmpStrFind
                        .Replacement.Text = ""
                        .Forward = True
                        .Wrap = wdFindStop
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                        .Execute
                    End With
                    Do While .Find.Found
                        For tmpInd = 2 To Len(tmpStrFind)
                            .Characters(tmpInd).Font.Superscript = True
                        Next tmpInd
                        .Collapse wdCollapseEnd
                        .Find.Execute
                    Loop
                End With
            Next tmdIndSupScrNumb
        Next tmdIndSupScrTxt
        
        ActiveWindow.View.Type = wdPrintView
    Application.ScreenUpdating = True
    
    MsgBox "Klaar."
    
    
    On Error GoTo 0
    Exit Sub
err_Handling:
    MsgBox "Error in macrAricKluwerSuperScript: (" & Err.Number & ") - " & Err.Description
    Resume Next
End Sub
Function fnctAricKluwerSuperScriptsSetArrays()
On Error GoTo err_Handling
    Dim tmpString               As String
    
    Erase glblArrSupScrNumbers
        tmpString = "0|1|2|3|4|5|6|7|8|9"   'De getallen in een array steken
    glblArrSupScrNumbers = Split(tmpString, "|")
    
    Erase glblArrSupScrTexts
        tmpString = "er|e|re|ste|de|ème|"    'Tekens na een getal die in superscript moeten komen
    glblArrSupScrTexts = Split(tmpString, "|")
    
    On Error GoTo 0
    Exit Function
err_Handling:
    MsgBox "Error in fnctAricKluwerSuperScriptsSetArrays: (" & Err.Number & ") - " & Err.Description
    Resume Next
End Function

Als jullie opmerkingen hebben op de code hoor ik het graag, ik sta altijd open voor verbeteringen!