Fastest way to remove 'extra' spaces (more

Question

I've been looking around and haven't found a great answer to the question on how to remove extra spaces from a large range of cells containing text strings. Let's say 5000+ cells.

some ways I have tried include:

For Each c In range
    c.Value = Trim(c.Value)
Next c

and

For Each c In range
    c = WorksheetFunction.Trim(c)
Next c

and

For Each c In range
    c.Value = Replace(c.Value, "     ", " ")
Next c

any ideas for speed improvement?

thank you in advance.

Answer 1

I'm usually using Evaluate than loops when it comes on large range. There are so many use of this function, but i won't discuss it further here.

'change the row count as deemed necessary..
Set rng = Range("C1:C" & Row.Count)

   rng.value = Evaluate("IF(" & rng.Address & "<>"""", _
               TRIM(" & rng.Address & "),"""")")

Set rng = Nothing

Answer 2

It can depend on many things, but in my case fastest was to get all values at once in array:

' Dim range As Range, r As Long, c As Long, a
a = range
For r = 1 To UBound(a)
    For c = 1 To UBound(a, 2)
        a(r, c) = Trim(a(r, c))
    Next
Next
range = a

Answer 3

Do you have a spare column next to it?

Range("B1:B" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "=Trim(A1)"
Columns(2).copy
Range("B1").PasteSpecial xlPasteValues
Columns(1).delete

Answer 4

The loop is killing you. This will remove spaces in an entire column in one shot:

Sub SpaceKiller()
   Worksheets("Sheet1").Columns("A").Replace _
      What:=" ", _
      Replacement:="", _
      SearchOrder:=xlByColumns, _
      MatchCase:=True
End Sub

Adjust the range to suit. If you want to remove double spaces, then:

Sub SpaceKiller()
   Worksheets("Sheet1").Columns("A").Replace _
      What:="  ", _
      Replacement:=" ", _
      SearchOrder:=xlByColumns, _
      MatchCase:=True
End Sub

EDIT#1:

This version will replace doubles with singles and then check if there are still still doubles left!

Sub SpaceKiller3()
   Worksheets("Sheet1").Columns("A").Replace _
      What:="  ", _
      Replacement:=" ", _
      SearchOrder:=xlByColumns, _
      MatchCase:=True

   Set r = Worksheets("Sheet1").Columns("A").Find(What:="  ")
   If r Is Nothing Then
      MsgBox "done"
   Else
      MsgBox "please run again"
   End If
End Sub

You can re-run until you see done

EDIT#2:

based on Don Donoghue's comment, this version will run recursively until all double are converted to singles:

Sub SpaceKiller3()
   Worksheets("Sheet1").Columns("A").Replace _
      What:="  ", _
      Replacement:=" ", _
      SearchOrder:=xlByColumns, _
      MatchCase:=True

   Set r = Worksheets("Sheet1").Columns("A").Find(What:="  ")
   If r Is Nothing Then
      MsgBox "done"
   Else
      Call SpaceKiller3
   End If
End Sub