Sub Schrift()
Dim osld As Slide
Dim oshp As Shape
Dim oTemp As TextRange
Dim i As Integer
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
Set oTemp = oshp.TextFrame.TextRange
For i = 1 To Len(oTemp)
If oTemp.Characters(i).Font.Name = "Calibri" Then _
oTemp.Characters(i).Font.Name = "Calibri Light"
Next
End If
End If
Next oshp
Next osld
Set oTemp = Nothing
Dim xsld As Slide
Dim xshp As Shape
Dim xTemp As TextRange
Dim y As Integer
For Each xsld In ActivePresentation.Slides
For Each xshp In xsld.Shapes
If xshp.HasTextFrame Then
If xshp.TextFrame.HasText Then
Set xTemp = xshp.TextFrame.TextRange
For y = 1 To Len(xTemp)
If xTemp.Characters(y).Font.Bold = True Then _
xTemp.Characters(y).Font.Name = "Calibri"
Next
End If
End If
Next xshp
Next xsld
Set xTemp = Nothing
End Sub