Any regulars here want to take a stab at this see:
Vertically Center Selected Range in the Useable ActiveWindow
There is some code floating about published by Andreas Killer about 10 years ago for centering selected text in the active window:
Code:
Sub SelectionScrollIntoMiddleOfView3() 'https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-msoffice_custom-mso_2010/centre-selected-text-in-the-middle-of-the-screen/84ab25fe-9570-4b55-91bd-4b11a04bb99b?auth=1
Dim pLeft As Long
Dim pTop As Long, lTop As Long, wTop As Long
Dim pWidth As Long
Dim pHeight As Long, wHeight As Long
Dim Direction As Integer
wHeight = PixelsToPoints(ActiveWindow.Height, True)
ActiveWindow.GetPoint pLeft, wTop, pWidth, pHeight, ActiveWindow
ActiveWindow.ScrollIntoView Selection.Range
ActiveWindow.GetPoint pLeft, pTop, pWidth, pHeight, Selection.Range
Direction = Sgn((pTop + pHeight / 2) - (wTop + wHeight / 2))
Do While Sgn((pTop + pHeight / 2) - (wTop + wHeight / 2)) = Direction And (lTop <> pTop)
ActiveWindow.SmallScroll Direction, down
On Error Resume Next
lTop = pTop
ActiveWindow.GetPoint pLeft, pTop, pWidth, pHeight, Selection.Range
Loop
End Sub
My experience here is that is simply doesn't work. First it doesn't compile because of the Direction, down line but even removing the "down", it still does nothing (most of the time).
I've put some example images in the linked thread and I've managed to put this together which (for me) works better, but there is an unresolved issue if the selected text spans more than one line. For me (and on my PC and ActiveWindow), one line of selected text returns a value of 28 and I can tweak the centering to using that value. That may not work for everyone. Can't figure out how to nail the center of the selected text to the center of the active window. All suggestions welcome!!
Code:
Sub SelectionScrollIntoMiddleOfView()
Dim lngLeft As Long, lngTop As Long, lngWidth As Long, lngHeight As Long
Dim lngWinTop As Long, lngWinUseableHgt As Long
Dim lngScroll As Integer
Dim lngCenter As Long, lngWinCenter As Long
Dim lngCenAdj As Long, lngIndex As Long '***
lngWinUseableHgt = ActiveWindow.UsableHeight
lngWinTop = ActiveWindow.Top
lngWinCenter = (lngWinTop + lngWinUseableHgt + 1) / 2
ActiveWindow.ScrollIntoView Selection.Range
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = (lngTop + lngHeight) / 2
lngScroll = Sgn(lngCenter - lngWinCenter)
lngCenAdj = ((lngHeight / 28) - 1) / 2 '*** On my screen, a slection of one line returns 28
Do Until Abs(lngCenter - lngWinCenter) < 10
ActiveWindow.SmallScroll lngScroll
ActiveWindow.GetPoint lngLeft, lngTop, lngWidth, lngHeight, Selection.Range
lngCenter = (lngTop + lngHeight) / 2
Loop
'*** Adjust center based on height of selection
If lngCenAdj > 0 Then
For lngIndex = 1 To lngCenAdj
If lngScroll = 1 Then ActiveWindow.SmallScroll -1
If lngScroll = -1 Then ActiveWindow.SmallScroll -1
Next lngIndex
End If
lbl_Exit:
Exit Sub
End Sub