Удалить лишние пробелы

Function УдалитьЛишниеПробелы(r As Range)
Dim arr() As String
arr() = Split(r)

For i = 0 To UBound(arr)
  If Len(arr(i)) > 0 And i > UBound(arr) Then
    arr(i) = arr(i)
   Exit Function
  End If
Next i
УдалитьЛишниеПробелы = Join(arr(), " ")
End Function

'макрос удаляет лишние пробелы в выделенном диапазоне, работает оч бысто
Sub TRIMinSelection()
    ' Преобразует все ячейки в выделенном диапазоне в верхний регистр
    Dim rngRectangle As Range, rngRows As Range, rngColumns As Range
    Set rngRectangle = Selection
    ' Определяет вертикальный вектор массива
    Set rngRows = rngRectangle.Resize(, 1)
    ' Определяет горизонтальный вектор массива
    Set rngColumns = rngRectangle.Resize(1)
    rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "), IF(COLUMN(" & rngColumns.Address & "),TRIM(" & rngRectangle.Address & ")))")
End Sub

PROPER
' PROPER
Sub ПРОПНАЧ2000()
    ' Преобразует все ячейки в выделенном диапазоне в верхний регистр
    Dim rngRectangle As Range, rngRows As Range, rngColumns As Range
    Set rngRectangle = Selection
    ' Определяет вертикальный вектор массива
    Set rngRows = rngRectangle.Resize(, 1)
    ' Определяет горизонтальный вектор массива
    Set rngColumns = rngRectangle.Resize(1)
    rngRectangle = Evaluate("IF(ROW(" & rngRows.Address & "), IF(COLUMN(" & rngColumns.Address & "),PROPER(" & rngRectangle.Address & ")))")
End Sub