Clear extra characters from a provided range of cells

[imran1059]

Dear All,

I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when lines are in thousands, Can somebody provide a more efficient code?

Sub ClearExtraCharacters()
Dim rng As Range, cell As Range

On Error Resume Next
Set rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub


For Each cell In rng.Cells
cell.Value = AlphaNumericOnly(cell.Value)
Next cell

MsgBox "Fixed", 48, "Fixed"
End Sub

 

[imran1059]

Check whether this is quicker :

Sub ClearExtraCharacters()
Dim rng As Range, i%
On Error Resume Next
Set rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
For i = 33 To 46
    rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 58 To 64
    rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 91 To 96
       rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 123 To 190
    rng.Replace "~" & Chr(i), "", xlPart
Next
MsgBox "Fixed", 48, "Fixed"
End Sub

This is much faster than my earlier code even without screen updating off and event procedure disabling. Many thanks for this. However, if anyone can tell me how to add screen updating off and even procedure disabling in this above code, it might be quicker than the blink of an eye.

 

[Yongle]

Try this in a COPY of your workbook

Sub TestAlphaN()
    Dim myArray As Variant, i As Long, j As Long, x As String
    myArray = Selection

For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        x = myArray(i, j)
        x = AlphaNumericOnly(x)
        myArray(i, j) = x
    Next j
Next i
    Selection = myArray
End Sub

'above calls your original function

 

[Yongle]

or you may prefer this

Sub ClearExtraCharacters()
   Dim myArray As Variant, i As Long, j As Long, x As String, rng As Range

    On Error Resume Next
    Set rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub Else myArray = rng

For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        x = myArray(i, j)
        x = AlphaNumericOnly(x)
        myArray(i, j) = x
    Next j
Next i
    rng = myArray

MsgBox "Fixed", 48, "Fixed"
End Sub

 

[imran1059]

or you may prefer this

Sub ClearExtraCharacters()
   Dim myArray As Variant, i As Long, j As Long, x As String, rng As Range

    On Error Resume Next
    Set rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub Else myArray = rng

For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        x = myArray(i, j)
        x = AlphaNumericOnly(x)
        myArray(i, j) = x
    Next j
Next i
    rng = myArray

MsgBox "Fixed", 48, "Fixed"
End Sub

Thats awesome .... fantastic. Thumbs up.

 

[footoo]

This is much faster than my earlier code even without screen updating off and event procedure disabling. Many thanks for this. However, if anyone can tell me how to add screen updating off and even procedure disabling in this above code, it might be quicker than the blink of an eye.

You wrote in in an earlier post:
99% of the times there is an extra apostrophe character in the beginning of the text in any given cell.
Are you sure the code I posted gets rid of these apostrophes?
What about spaces - do you also want to remove?

 

[imran1059]

You wrote in in an earlier post:
99% of the times there is an extra apostrophe character in the beginning of the text in any given cell.
Are you sure the code I posted gets rid of these apostrophes?
What about spaces - do you also want to remove?

It clears apostrophe but it also clears decimals (points) if there are numbers in some cells. e.g. 0.02 is converted into 2. So it seems this code is not suitable for my case. I do not want to remove spaces within the text of the cell. However, if some space is there in any cell in the beginning of the text then for sure I would like to have it removed.

 

[imran1059]

or you may prefer this

Sub ClearExtraCharacters()
   Dim myArray As Variant, i As Long, j As Long, x As String, rng As Range

    On Error Resume Next
    Set rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub Else myArray = rng

For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        x = myArray(i, j)
        x = AlphaNumericOnly(x)
        myArray(i, j) = x
    Next j
Next i
    rng = myArray

MsgBox "Fixed", 48, "Fixed"
End Sub

In same code please add to read and fix if some space is there in any cell in the beginning of the text then that should be removed.

 

[footoo]

It clears apostrophe but it also clears decimals (points) if there are numbers in some cells. e.g. 0.02 is converted into 2. So it seems this code is not suitable for my case. I do not want to remove spaces within the text of the cell. However, if some space is there in any cell in the beginning of the text then for sure I would like to have it removed.

Sub ClearExtraCharacters()
Dim myArray As Variant, i As Long, j As Long, x As String, Rng As Range
On Error Resume Next
Set Rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub Else myArray = Rng
For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        myArray(i, j) = Trim(myArray(i, j))
    Next j
Next i
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Rng = myArray
For i = 33 To 45
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 58 To 64
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 91 To 96
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 123 To 190
    Rng.Replace "~" & Chr(i), "", xlPart
Next
    .ScreenUpdating =True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Fixed", 48, "Fixed"
End Sub

 

[imran1059]

Sub ClearExtraCharacters()
Dim myArray As Variant, i As Long, j As Long, x As String, Rng As Range
On Error Resume Next
Set Rng = Application.InputBox("Select Range", "Range Selection", , , , , , 8)
On Error GoTo 0
If Rng Is Nothing Then Exit Sub Else myArray = Rng
For i = LBound(myArray, 1) To UBound(myArray, 1)
    For j = LBound(myArray, 2) To UBound(myArray, 2)
        myArray(i, j) = Trim(myArray(i, j))
    Next j
Next i
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
Rng = myArray
For i = 33 To 45
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 58 To 64
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 91 To 96
    Rng.Replace "~" & Chr(i), "", xlPart
Next
For i = 123 To 190
    Rng.Replace "~" & Chr(i), "", xlPart
Next
    .ScreenUpdating =True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
MsgBox "Fixed", 48, "Fixed"
End Sub

Hi Footoo, I must thank you for your efforts. Your this code solved two things. First, it did not remove decimal(point) and secondly it successfully removed beginning spaces. However, it did not remove apostrophes. Although, it hides apostrophe but in cells its there. please see attached image. your earlier code was removing apostrophe completely. Also, your this code takes around 15-20 seconds to execute when applied to around 10K lines with 14 columns. In addition to that it also gives a little scares as the screen blinks a couple of times within these 15-20 seconds. Code that was provided by Yongle is must faster as it gives me the desired outcome in less than 5 seconds without screen flickers but there the beginning spaces are not removed. I hope i explained it.

 

[Yongle]

Code that was provided by Yongle ...but there the beginning spaces are not removed. I hope i explained it.

If ALL spaces are to be removed, replace 32 with 33 in the line beginning Case ...

Case 33 To 38, 40 To 62, 64 To 126