VBA - Tekst doorlopen en alle getallen in superscript plaatsen

[Pieter671]

Hallo,

Ik ben op zoek naar een VBA-script dat de gehele tekst doorloopt en alle getallen die in die tekst staan als tekstopmaak superscript aanmerkt.
De VBA-script zou mij heel veel handwerk besparen.

Voorbeeld:

1Dit is de eerste zin. 2Dit is de tweede alinea. 3Dit is weer het volgende blok voorafgegaan door een nummer.

Groet,
Pieter

 

[Pieter671]

VBA - script.

Het is mogelijk toch iets gemakkelijker dan ik dacht. Met de macro-recorder en wat kleine aanpassingen kom je een heel eind.
Zie hieronder.

Toch nog een aanvullende vraag:

Als je dit script laat lopen op een tekst komt er bij ieder "zoek en vervang"-opdracht een bevestigingsscherm met de vraag of dit vervangen moet worden.

Is dit scherm met VBA te passeren door altijd een definitief "JA" te geven.



xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

Sub Omzetten()
'
' Alle getallen in tekst omzetten naar Superscript
'
'
Teller = 0

Selection.WholeStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.Replacement.Font
.Bold = True
.Superscript = True
.Subscript = False
End With

Do While Teller < 10

With Selection.Find
.Text = Teller
.Replacement.Text = Teller
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.Find.Execute Replace:=wdReplaceAll

Teller = Teller + 1

Loop

End Sub

xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

 

[OctaFish]

Het kan allemaal wel wat simpeler, en netter. Om met dat laatste te beginnen: gebruik de volgende keer CODE tags om je code op te maken. En probeer deze eens uit:

Sub GetalBlauw()
Dim doc As Document
Dim arr
Dim i As Long
    Set doc = ActiveDocument
    arr = Split(doc.Content)
    For i = LBound(arr) To UBound(arr)
        If IsNumeric(arr(i)) Then
            With doc.Content.Find
                .ClearFormatting
                .Text = arr(i)
                With .Replacement
                    .ClearFormatting
                    .Font.Bold = True
                    .Font.ColorIndex = wdBlue
                End With
                .Execute FindText:=arr(i), ReplaceWith:=arr(i), Format:=True, Replace:=wdReplaceAll
            End With
        End If
    Next i
End Sub

 

[Pieter671]

@OctaFish,

Ziet er indrukwekkend uit. Als beginnende VBA-er vraagt dit voor mij wat studie.
Ubound en Lbound beginnen duidelijk te worden. Maar op één of andere manier worden toch gedeelten in de array overgeslagen.

Reactie op resultaat:
Als ik de macro laat lopen, dan worden niet alle cijfers veranderd in de kleur blauw.

Als ik 'm met F8 stap voor stap doorloop, dan lijkt het dat er bij "If IsNumeric(arr(i)) Then" een paar stappen worden overgeslagen.

Pieter

 

[OctaFish]

Dat zijn dan geheid 'getallen' waar ook tekst in zit.

 

[Pieter671]

OctaFish,

Zie hier een voorbeeld. Probeer de macro op dit bestand maar eens.

Bekijk bijlage voorbeeld tekst 2.docx


Pieter

 

[OctaFish]

Dan splitsen we 'm wat fijner op .

Sub GetalBlauw()
Dim doc As Document
Dim arrA As Variant, arrW As Variant
Dim i As Long, b As Integer

    Set doc = ActiveDocument
    arrA = Split(doc.Content, Chr(13))
    For i = LBound(arrA) To UBound(arrA)
        arrW = Split(arrA(i), " ")
        For b = LBound(arrW) To UBound(arrW)
            If IsNumeric(arrW(b)) Then
                With doc.Content.Find
                    .ClearFormatting
                    .Text = arrW(b)
                    With .Replacement
                        .ClearFormatting
                        .Font.Bold = True
                        .Font.ColorIndex = wdBlue
                    End With
                    .Execute FindText:=arrW(b), ReplaceWith:=arrW(b), Format:=True, Replace:=wdReplaceAll
                End With
            End If
        Next b
    Next i
    MsgBox "Alle getallen omgezet!", vbOKOnly
End Sub

 

[Pieter671]

OctaFish,

Meer dan top, thanx.

Pieter