Leave Only Mobile Numbers & Delete all Text or any Characters in given Range

[Prasad K]

Hi Excel Experts I Need Help in VBA Macro

I have customer data in my excel sheet Column A to Column E & here I found a VBA Code on Google Search to Delete all Text or any Special Character & leave only mobile numbers in a given Range when I run VBA Code

Here what I want in Column B I have Customer Mobile Numbers with Address in Column B I want to delete all text or any character and just leave only 10 digit mobile numbers only in that range Because in my sheet already Customer Address in Column E

When I run this VBA Code in given Range on Column B it’s working perfectly & here what the problem I have getting with this VBA it’s deleting all text or any character in that range what I am expecting & here problem is it’s deleting mobile numbers also like if cell have 2 or 3 mobile numbers then this VBA is Leaving Only 1 Mobile number in that cell and deleting remaining mobile numbers in that range

Here what I want when I run this VBA it’s just delete only text or any character on that range never delete any mobile number


This is Original Data

value function.xlsx
	A	B	C	D	E
1	Customer Name	Customer Mobile	Service B or C	Service Charge	Customer Address & City
2	Ajay Kumar	7412589632 , Ram Nagar, Hyderabad	C	₹ 3,250	Ram Nagar , Hyderabad
3	Pavan Sekhar	6541239874 | 9632587412 , Santhosh Nagar, Secunderabad	C	₹ 4,120	Santhosh Nagar, Secunderabad
4	Chandra Kumar	2135468793 , Kali Pet Nagar, Warangal	B	₹ 1,725	Kali Pet Nagar, Warangal
5	Meenakshi Sharma	2587413698 | 3214569874 | 5462139875 , Hanuman Colony, Hyderabad	C	₹ 2,453	Hanuman Colony, Hyderabad
6	Atul Prasad	4172589635 Champak Pet, Hyderabad	B	₹ 1,420	Champak Pet, Hyderabad
7	Arun Patel	3697412581 | 5421789632 , Machili Pet Nagar, Warangal	B	₹ 1,247	Machili Pet Nagar, Warangal
8	Sekhar Chandra	2476387421 , Asura Nagar, Hyderabad	C	₹ 3,240	Asura Nagar, Hyderabad
Sheet2

when i run this VBA it's getting output like this

value function.xlsx
	A	B	C	D	E
1	Customer Name	Customer Mobile	Service B or C	Service Charge	Customer Address & City
2	Ajay Kumar	7412589632	C	₹ 3,250	Ram Nagar , Hyderabad
3	Pavan Sekhar	6541239874	C	₹ 4,120	Santhosh Nagar, Secunderabad
4	Chandra Kumar	2135468793	B	₹ 1,725	Kali Pet Nagar, Warangal
5	Meenakshi Sharma	2587413698	C	₹ 2,453	Hanuman Colony, Hyderabad
6	Atul Prasad	4172589635	B	₹ 1,420	Champak Pet, Hyderabad
7	Arun Patel	3697412581	B	₹ 1,247	Machili Pet Nagar, Warangal
8	Sekhar Chandra	2476387421	C	₹ 3,240	Asura Nagar, Hyderabad
Sheet2

when i run VBA i want to get OutPut Result like this Below

value function.xlsx
	A	B	C	D	E
1	Customer Name	Customer Mobile	Service B or C	Service Charge	Customer Address & City
2	Ajay Kumar	7412589632	C	₹ 3,250	Ram Nagar , Hyderabad
3	Pavan Sekhar	6541239874|9632587412	C	₹ 4,120	Santhosh Nagar, Secunderabad
4	Chandra Kumar	2135468793	B	₹ 1,725	Kali Pet Nagar, Warangal
5	Meenakshi Sharma	2587413698|3214569874|5462139875	C	₹ 2,453	Hanuman Colony, Hyderabad
6	Atul Prasad	4172589635	B	₹ 1,420	Champak Pet, Hyderabad
7	Arun Patel	3697412581|5421789632	B	₹ 1,247	Machili Pet Nagar, Warangal
8	Sekhar Chandra	2476387421	C	₹ 3,240	Asura Nagar, Hyderabad
Sheet2

Sub OnlyNumber()
Dim s As String
Dim ReturnVal As String
Dim i As Integer
Dim lastRow As Long

ReturnVal = ""
lastRow = Range("B" & Rows.Count).End(xlUp).Row

    For c = 1 To lastRow
        s = Range("B" & c).Value
            For i = 1 To Len(s)
                If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
                ReturnVal = ReturnVal + Mid(s, i, 1)
                End If
            Next i
        If Len(ReturnVal) > 10 And Len(ReturnVal) <= 14 Then
            Range("B" & c).Value = Right(ReturnVal, 10)
            ElseIf Len(ReturnVal) > 14 Then
                Range("B" & c).Value = Left(ReturnVal, 10)
                ElseIf Len(ReturnVal) = 10 Then
                    Range("B" & c).Value = ReturnVal
                    Else
                    MsgBox ("defined number structure")
        End If
        ReturnVal = ""
    Next c
End Sub

 

[bebo021999]

Assume text part always start from 1st alphabet string:

Sub test()
Lr = Cells(Rows.Count, "B").End(xlUp).Row
For Each cell In Range("B2:B" & Lr)
    For i = 1 To Len(cell)
        If Asc(LCase(Mid(cell, i, 1))) < 123 And Asc(LCase(Mid(cell, i, 1))) > 96 Then 'search for first alphabet letter
        cell.Offset(, 3).Value = Mid(cell, i, 255)                                      ' write Address
        cell.Value = Left(cell, i - 3)                                                  ' write tel
        Exit For
        End If
    Next
Next
End Sub

 

[Prasad K]

@ Prasad K
like this

Sub test()
    a = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
    With CreateObject("VBScript.RegExp")
        .Pattern = " [a-zA-Z]+|\,.[a-zA-Z].+"
        For i = 1 To UBound(a)
            a(i, 1) = .Replace(a(i, 1), "")
        Next
        Cells(2, 2).Resize(UBound(a)) = a
    End With
End Sub

Thank you so much sir it's working perfectly has i expected and one small problem it's not deleting complete text in one cell can you fix this

value function.xlsm
	B
1	Customer Mobile
2	7412589632
3	6541239874 | 9632587412
4	2135468793
5	2587413698 | 3214569874 | 5462139875
6	4172589635 Pet, Hyderabad
7	3697412581 | 5421789632
8	2476387421
Sheet2

 

[Prasad K]

Assume text part always start from 1st alphabet string:

Sub test()
Lr = Cells(Rows.Count, "B").End(xlUp).Row
For Each cell In Range("B2:B" & Lr)
    For i = 1 To Len(cell)
        If Asc(LCase(Mid(cell, i, 1))) < 123 And Asc(LCase(Mid(cell, i, 1))) > 96 Then 'search for first alphabet letter
        cell.Offset(, 3).Value = Mid(cell, i, 255)                                      ' write Address
        cell.Value = Left(cell, i - 3)                                                  ' write tel
        Exit For
        End If
    Next
Next
End Sub

View attachment 52751

Thank you sir your code also working perfectly i have tested now

here is a problem it's deleting 1 number in 10 digit mobile number on 6 row

 

[bebo021999]

Sorry about that. Below adjustment should be neater:

cell.Value = application.trim(substitute(Left(cell, i - 1) ,",",""))

 

[mohadin]

Hi
One typo in my cod

Sub test()
    a = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
    With CreateObject("VBScript.RegExp")
        .Pattern = " [a-zA-Z]+|\,.[a-zA-Z].+"
        .Global = True
        For i = 1 To UBound(a)
            a(i, 1) = .Replace(a(i, 1), "")
        Next
        Cells(2, 2).Resize(UBound(a)) = a
    End With
End Sub

 

[Prasad K]

Hi
One typo in my cod

Sub test()
    a = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
    With CreateObject("VBScript.RegExp")
        .Pattern = " [a-zA-Z]+|\,.[a-zA-Z].+"
        .Global = True
        For i = 1 To UBound(a)
            a(i, 1) = .Replace(a(i, 1), "")
        Next
        Cells(2, 2).Resize(UBound(a)) = a
    End With
End Sub

Excellent Thank you so much

 

[alansidman]

Power Query is a free AddIn for Excel 2010 and 2013, and is built-in functionality from Excel 2016 onwards (where it is referred to as "Get & Transform Data").

It is a powerful yet simple way of getting, changing and using data from a broad variety of sources, creating steps which may be easily repeated and refreshed. I strongly recommend learning how to use Power Query - it's among the most powerful functionalities of Excel.

- Follow this link to learn how to install Power Query in Excel 2010 / 2013.

- Follow this link for an introduction to Power Query functionality.

- Follow this link for a video which demonstrates how to use Power Query code provided.

 

[mohadin]

You are welcome
And thank you for the feedback
Be happy and safe