Как во всей книге Excel из 10-ти листов удалить " " двойные и более пробелы на " "

Sub RSpace()
    Dim i&, j&, lLastRow&, lLastCol&
    Dim iCount%, iArr%
    Dim str$
    Dim ws As Worksheet
    For iCount = 1 To ThisWorkbook.Worksheets.Count 'перебираем все листы книги
        Set ws = ThisWorkbook.Worksheets(iCount) 'запоминаем текущий лист
        lLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row 'определяем последнюю строку по первому столбцу
        lLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'определяем последний столбец по строке по первой строке
        For i = 1 To lLastRow 'перебираем строки
            For j = 1 To lLastCol 'перебираем столбцы
                Dim Arr() As String 'объявляем массив слов
                Arr = Strings.Split(ws.Cells(i, j).Value, " ") 'разделяем строку по словам, разделенными пробелами
                str = ""
                For iArr = 0 To UBound(Arr) 'перебираем все слова в массиве
                    If Strings.Len(Strings.Replace(Arr(iArr), " ", "")) > 0 Then str = str & Strings.Replace(Arr(iArr), " ", "") & " " 'собираем новую строку с одним пробелом, если элемент массива не состоит только из пробелов
                Next iArr
                If Strings.Right(str, 1) = " " Then
                    str = Strings.Left(str, Strings.Len(str) - 1) 'удаляем последний пробел
                End If
                ws.Cells(i, j).Value = str 'возвращаем значение в ячейку уже с одним пробелом между словами
            Next j
        Next i
    Next iCount
    MsgBox "Done"
End Sub

s=ws.Cells(i, j).Value
while instr(s,"  ")
  s=replace(s,"  "," ")
wend
ws.Cells(i, j).Value=trim$(s)

Sub RSpace()
  Dim ws As Worksheet, c As Range, s As String
  For Each ws In ThisWorkbook.Worksheets
    For Each c In ws.UsedRange
      s = c.Value
      While InStr(s, "  ")
        s = Replace(s, "  ", " ")
      Wend
      c = Trim$(s)
    Next
  Next
End Sub

Sub RSpace()
  Dim ws As Worksheet, c As Range, s As String
  Dim cs&, cc&
  For Each ws In ThisWorkbook.Worksheets
    For Each c In ws.UsedRange
      s = c.Value
      While InStr(s, "  ")
        s = Replace(s, "  ", " ")
      Wend
      cs = cs + Len(c.Value) - Len(Trim$(s))
      cc = cc - (c.Value <> Trim$(s))
      c = Trim$(s)
    Next
  Next
  MsgBox "К-во измененных ячеек - " & cc & vbLf & "К-во удаленных пробелов - " & cs
End Sub

Sub Соединить_через_запятую()
    Const sDELIM As String = " "     'символ-разделитель
    Dim rCell As Range
    Dim sMergeStr As String
    If TypeName(Selection) <> "Range" Then Exit Sub   'если выделены не ячейки - выходим
    With Selection
        For Each rCell In .Cells
            sMergeStr = sMergeStr & "," & sDELIM & rCell.Text  'собираем текст из ячеек
        Next rCell
        Application.DisplayAlerts = False   'отключаем стандартное предупреждение о потере текста
        .Merge Across:=False                'объединяем ячейки
        Application.DisplayAlerts = True
        .Item(1).Value = Mid(sMergeStr, 1 + Len(sDELIM))    'добавляем к объед.ячейке суммарный текст
    End With
End Sub