Faster way to remove 'extra' spaces (more than 1) from a large range of cells using VBA for Excel

How do I remove extra spaces faster, 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?

Solution 1:

Late to the party but...

There is no need for iteration through cells/values nor a recursive function to search and replace multiple spaces in a range.

Application.Trim wil actually take care of multiple spaces between words (and will trim leading/trailing spaces) leaving single spaces in between words intact.

The great thing about it, is that you can feed the function a full range (or array) to do this operation in one sweep!

Sub Test()

Dim rng As Range
Set rng = Sheets("Sheet1").Range("A1:A3")
rng.Value = Application.Trim(rng)

End Sub

The one thing to take into consideration is that this way you'll overwrite any formulas sitting in your target range with its value. But as per your question, you working with a Range object containing text values. There was just no need for iteration =)

Solution 2:

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

Solution 3:

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

Solution 4:

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