Removing telephone numbers from a cell + general questions

[InTheDogHouse]

Hello

This is my first time posting. I have a limited amount of VBA knowledge. My limited knowledge is based on solving my problems by looking at the answers already on this site and trying to adapt it to my needs. Here goes:

I import a list of address and telephone numbers (100+) into excel. example - Cell A1 contains "10 downing street, whitehall, london, SW1A 2AA 01234 567890", sometimes there is another space after the number, sometimes there is no telephone number. I want to remove the telephone number at the end if it is there. Have searched the forums have have come up with the follow solution:

1. import list to column A
2. copy and paste Trim to column B
3. copy values in column B and paste to column A
4. delete column B
5. remove the end numbers
6. copy and paste Trim to column B
7. copy values in column B and paste to column A
8. delete column B
9. remove the end numbers

It looks like this in code:

Sub testa()

'select (=TRIM(A1)) formula and paste to sheet
Sheets("Formulas").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Columns("B:B").Select
ActiveSheet.Paste

End Sub

Sub testb()

'remove last set of numbers
Dim cellText As String
Dim i As Integer
For i = 1 To 10000
Range("A" & i).Select
'Get the text from the cell
cellText = Selection.Text
'As long as there is a number on the right, chop it off
While IsNumeric(Right(cellText, 1))
cellText = Left(cellText, Len(cellText) - 1)
Wend
'Write the new text string back into the cell
Selection.Value = cellText

Next

End Sub

Sub testc()

'copy values of column B to Column A and delete column B

Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select

End Sub

Sub testd()

'select (=TRIM(A1)) formula and paste to sheet
Sheets("Formulas").Select
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Columns("B:B").Select
ActiveSheet.Paste

End Sub

Sub teste()

'remove last set of numbers
Dim cellText As String
Dim i As Integer
For i = 1 To 10000

Range("A" & i).Select
'Get the text from the cell
cellText = Selection.Text
'As long as there is a number on the right, chop it off
While IsNumeric(Right(cellText, 1))
cellText = Left(cellText, Len(cellText) - 1)
Wend
'Write the new text string back into the cell
Selection.Value = cellText
Next

End Sub

Sub testf()

'copy values of column B to Column A and delete column B

Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select


End Sub

I know this is a long winded way around (still chuffed I worked it out by myself though!). If I merge all the macros into one marco it continually loops and deletes everything in the cells and I have to press escape to stop it.

My questions are:
1. Why, when I merge all the macros doesnt it work the same as individual macros? (I would like to know for future reference).
2. Its there a better way to remove the telephone numbers?

Many thanks

InTheDogHouse

 

[S.H.A.D.O.]

To run them all together, you could use something like this...

Sub Merge_Macros()
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False
    End With
    Call testa
    Call testb
    Call testc
    Call testd
    Call teste
    Call testf
    With Application
        .DisplayAlerts = True: .Calculation = xlCalculationAutomatic: .ScreenUpdating = True
    End With
End Sub

I hope this helps!

 

[InTheDogHouse]

Thanks for your reply.
I am trying to learn more about VBA. What does:

With Application .ScreenUpdating = False: .Calculation = xlCalculationManual: .DisplayAlerts = False End With

do?

Many Thanks

 

[stoolpidgeon]

This should do the trick

Function test(x As Range)
Dim myArr As Variant
Dim newStr As String
Dim temp As String
Dim counter As Integer, i As Integer
counter = 0
temp = CStr(x.Value)
myArr = Split(temp, " ")
For Each entry In myArr
    If IsNumeric(Right(entry, 5)) Then
        counter = counter + 1
    End If
Next entry
For j = 0 To UBound(myArr) - (counter - 1)
    newStr = newStr & " " & myArr(j)
Next j
test = newStr
End Function

(Sorry made a couple of modifications since first post)