Макрос быстрого поиска и замены но (не обрабатывает двойные слова)

Sub Trans()
Dim C As New Collection
Dim W As Range, R As Range
Dim S As String, S2 As String

    C.Add Item:="Кот", Key:="Cat"
    C.Add Item:="Снуп дог", Key:="Snup Dog"
    C.Add Item:="Пять", Key:="Five"
    C.Add Item:="Проблема с несколькими словами т.к key ", Key:="The problem with a few words unnecessarily"
'(Как можно исправить )
    C.Add Item:="and", Key:=" "
    
For Each W In ActiveDocument.Range.Words
        Set R = W.Duplicate
        R.MoveEndWhile _
            CSet:=Chr$(32) & Chr$(160), _
            Count:=wdBackward
        If R.Start >= R.End Then GoTo NEXTW
           S = "": S = LCase$(R.Text)
               On Error Resume Next
        S2 = "": S2 = C.Item(S)
        If Err.Number <> 0 Then GoTo NEXTW
             R.Text = S2
NEXTW:
    Next W
    
End Sub