Переобразовать строку так, чтобы между словами был ровно один пробел

Private Sub Command1_Click()
    Dim s As String
    s = "Дана             строка-предложение       с            избыточными      пробелами                 между             словами.          Переобразовать         её       так,      чтобы между              словами        был            ровно   один          пробел."
    Do While InStr(1, s, "  ")
        s = Replace(s, "  ", " ")
    Loop
    MsgBox s
End Sub

s=trim(s) 'неплохо бы добавить (лидирующие и концевые пробелы даже в одном экземпляре часто приводят к недоразумениям)

Function NoProbels$(ByVal Text$, Optional ascd As Byte = 32)
 
    Dim chrb2$(1)
    chrb2(0) = Chr$(ascd): chrb2(1) = String(2, ascd)
    While NoProbels <> Text
        NoProbels = Text
        Text = Replace(Text, chrb2(1), chrb2(0))
    Wend
End Function
 
Private Sub Form_Load()
    MsgBox NoProbels("Привет                                Ксюша ! ")
    End
End Sub

Private Sub Form_Load()
    Dim s As String, p1 As Long, p2 As Long
    s = "Äàíà             ñòðîêà-ïðåäëîæåíèå       ñ            èçáûòî÷íûìè      ïðîáåëàìè                 ìåæäó             ñëîâàìè.          Ïåðåîáðàçîâàòü         å¸       òàê,      ÷òîáû ìåæäó              ñëîâàìè        áûë            ðîâíî   îäèí          ïðîáåë."
    p1 = 1: p2 = 1
    Do Until p2 > Len(s)
        Mid$(s, p1, 1) = Mid$(s, p2, 1): p1 = p1 + 1
        Do: p2 = p2 + 1: Loop While Mid$(s, p2, 2) = "  "
    Loop
    If p1 > 1 Then s = Left$(s, p1 - 1)
    Debug.Print s
End Sub