VBA Scrub clean

K

kevin440red

New Member
Joined
May 23, 2011
Messages
26
Office Version
  1. 2019
I have the Macro that cleans numbers up all the basic but when it runs in a table it is very slow on a regular excel sheet it is fast.
how can I speed it up? I select the range to scrub or clean.

VBA Code: 
Sub BAZINGA_007()
'PURPOSE: Determine how many seconds it took for code to completely run

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer
'*****************************
  
'Special Characters
    For Each cel In Selection
    For i = Len(cel.Value) To 1 Step -1
    Select Case Mid(cel.Value, i, 1)
    
    'This is an | sign
    Case Chr(124)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an   sign
    Case Chr(127)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an Spaces
     Case Chr(32)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an Spaces
     Case Chr(160)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an # sign
    Case Chr(35)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an _ sign
    Case Chr(95)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
        
    'This is an * sign
    Case Chr(42)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
        
    'This is an ` sign
    Case Chr(39)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
    
    'This is an - sign
    Case Chr(45)
    cel.Value = Left(cel.Value, i - 1) & Right(cel.Value, Len(cel.Value) - i)
        End Select
        Next i
        Next cel
        
        
'Removes Carriage Returns
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cell As range
'Also Treat CHR 0160, as a space (CHR 032)
Selection.Replace What:=Chr(160), Replacement:=Chr(32), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
'Do Same with carriage return (Alt-Enter)
'Also Treat CHR 010, as a space (CHR 032)
Selection.Replace What:=Chr(10), Replacement:=Chr(32), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
'Trim in Excel removes extra internal spaces, VBA does not
On Error Resume Next 'in case no text cells in selection
For Each cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
cell.Value = Application.Trim(cell.Value)
Next cell
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


  

     'Makes 10 digit

    Dim ThisCell As range
    Application.ScreenUpdating = False
    Selection.NumberFormat = "@"
    For Each ThisCell In Selection
    If Len(ThisCell) < 10 Then
    ThisCell = Right("0000000000" & ThisCell, 10)
        Else
        End If
    Next ThisCell
    Application.ScreenUpdating = True
            
 'Convert to General
    Selection.NumberFormat = "General"
    
 'Add Apostrophe to start of Part Number

    Dim c As range
    For Each c In Selection
    If c.Value <> "" Then c.Value = "'" & c.Value
        Next
        
'*****************************
'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Try the next version to make the changes but in memory.

VBA Code: 
Sub BAZINGA_007()
  Dim StartTime As Double
  Dim a As Variant, arr As Variant
  Dim i As Long, j As Long
  
  StartTime = Timer
  'Special Characters
  arr = Array(Chr(124), Chr(127), Chr(32), Chr(160), Chr(35), Chr(95), Chr(42), Chr(39), Chr(45))
  
  a = Selection.Value
  For i = 1 To UBound(a)
    For j = 0 To UBound(arr)
      a(i, 1) = Replace(a(i, 1), arr(j), "")
    Next
    a(i, 1) = Replace(a(i, 1), Chr(10), Chr(32))
    a(i, 1) = Trim(a(i, 1))
    If Len(a(i, 1)) < 10 Then a(i, 1) = Right("0000000000" & a(i, 1), 10)
    If a(i, 1) <> "" Then a(i, 1) = "'" & a(i, 1)
  Next i
  Selection.Value = a
  
  'Notify user in seconds
  MsgBox "This code ran successfully in " & Timer - StartTime & " seconds", vbInformation
End Sub
 
Upvote 0
Solution
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)


We don't know how big your table is or what part(s) of it you are selecting. I note that if a multi-column range is selected Dante's current code only processes the first column but there is an easy change if required.

If your table is very large then you may also try this which replaces any/all of the special characters in each cell value at once.
I have assumed that a single contiguous range is selected but that it could include multiple columns.

VBA Code: 
Sub Replace_Characters()
  Dim RX As Object
  Dim arr As Variant, a As Variant
  Dim i As Long, j As Long, uba2 As Long
 
  Dim t As Single
  t = Timer
 
  arr = Array(Chr(124), Chr(127), Chr(32), Chr(160), Chr(35), Chr(95), Chr(42), Chr(39), Chr(45))
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\" & Join(arr, "|\")

  Application.ScreenUpdating = False
  With Selection
    a = .Value
    uba2 = UBound(a, 2)
    For i = 1 To UBound(a)
      For j = 1 To uba2
        a(i, j) = RX.Replace(a(i, j), "")
        If Len(a(i, j)) < 10 Then a(i, j) = Right("0000000000" & a(i, j), 10)
      Next j
    Next i
    .Value = a
  End With
  Application.ScreenUpdating = True
  MsgBox "Code ran in " & Format(Timer - t, "0.000 secs")
End Sub
 
Upvote 0
DanteAmor said:
Try the next version to make the changes but in memory.

VBA Code: 
Sub BAZINGA_007()
  Dim StartTime As Double
  Dim a As Variant, arr As Variant
  Dim i As Long, j As Long
 
  StartTime = Timer
  'Special Characters
  arr = Array(Chr(124), Chr(127), Chr(32), Chr(160), Chr(35), Chr(95), Chr(42), Chr(39), Chr(45))
 
  a = Selection.Value
  For i = 1 To UBound(a)
    For j = 0 To UBound(arr)
      a(i, 1) = Replace(a(i, 1), arr(j), "")
    Next
    a(i, 1) = Replace(a(i, 1), Chr(10), Chr(32))
    a(i, 1) = Trim(a(i, 1))
    If Len(a(i, 1)) < 10 Then a(i, 1) = Right("0000000000" & a(i, 1), 10)
    If a(i, 1) <> "" Then a(i, 1) = "'" & a(i, 1)
  Next i
  Selection.Value = a
 
  'Notify user in seconds
  MsgBox "This code ran successfully in " & Timer - StartTime & " seconds", vbInformation
End Sub
Click to expand...
Nice and Fast Thank you
 
Upvote 0
Peter_SSs said:
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)


We don't know how big your table is or what part(s) of it you are selecting. I note that if a multi-column range is selected Dante's current code only processes the first column but there is an easy change if required.

If your table is very large then you may also try this which replaces any/all of the special characters in each cell value at once.
I have assumed that a single contiguous range is selected but that it could include multiple columns.

VBA Code: 
Sub Replace_Characters()
  Dim RX As Object
  Dim arr As Variant, a As Variant
  Dim i As Long, j As Long, uba2 As Long
 
  Dim t As Single
  t = Timer
 
  arr = Array(Chr(124), Chr(127), Chr(32), Chr(160), Chr(35), Chr(95), Chr(42), Chr(39), Chr(45))
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.Global = True
  RX.Pattern = "\" & Join(arr, "|\")

  Application.ScreenUpdating = False
  With Selection
    a = .Value
    uba2 = UBound(a, 2)
    For i = 1 To UBound(a)
      For j = 1 To uba2
        a(i, j) = RX.Replace(a(i, j), "")
        If Len(a(i, j)) < 10 Then a(i, j) = Right("0000000000" & a(i, j), 10)
      Next j
    Next i
    .Value = a
  End With
  Application.ScreenUpdating = True
  MsgBox "Code ran in " & Format(Timer - t, "0.000 secs")
End Sub
Click to expand...
Also a nice and Fast option Thank you
 
Upvote 0
Glad we could help & thanks for the feedback
 
Upvote 0
Glad the solutions worked for you. What about this though?
For the future, it would be very helpful to know this information.
Peter_SSs said:
I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
Need to double click on a cell before VBA code changes applies
Replies
6
Views
567
kevin9999
K
Jeffrey Mahoney
  • Question
AutoFilter Selected Items - Selecting non-structured Table
Replies
8
Views
389
Akuini
Akuini
X
  • Question
Removing leading line breaks in all the cells
Replies
5
Views
825
rollis13
rollis13
E
  • Solved
Subroutine to Add Cell Comments Not Updating the Contents Correctly
Replies
7
Views
342
CephasOz
CephasOz
M
  • Question
Excel VBA Set Activecell Formula With String
Replies
1
Views
481
Special-K99
S

Forum statistics

Threads
1,215,339
Messages
6,124,370
Members
449,155
Latest member
ravioli44

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top