Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Rng As Range
Set Rng = ActiveDocument.Range
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Format = True
    .Style = "Normal"
    .Forward = True
    .Wrap = wdFindStop
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    .Execute
  End With
  Do While .Find.Found
    If InStr(.Text, " ") > 0 Then
      i = GetMaxSpaces(.Text)
      If i > j Then j = i
    End If
    If .End = Rng.End Then Exit Do
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
MsgBox "The maximum space sequence is: " & j
End Sub
 
Function GetMaxSpaces(StrTxt As String)
Dim StrTmp As String, i As Long
StrTmp = " "
While InStr(StrTxt, StrTmp) > 0
    StrTmp = StrTmp & " "
    i = i + 1
Wend
GetMaxSpaces = i
End Function