Remove excess characters in url domain

[Mike TheSpike]

Hi there, pls help. this code is not working when i select specific column.

Sub removeExcess_domain()
Dim Cell As Range
Dim tmp As String
Dim Lr As Long

Lr = Cells(Rows.Count, "L").End(xlUp).Row

'loop through every cell in range and remove characters after ?

For Each Cell In Range("L2:L" & Lr)
    tmp = cell.Value
    '
    cell.Value = Left(tmp, InStr(tmp, "?") - 1)
Next
End Sub

Thanks for your help,
Mike

 

[Michael M]

Can you give us samples of what you are trying to achieve ?

 

[Mike TheSpike]

Hi @Michael M,

I want to remove all characters from ?

sample:

https://www.google.com/pg/nike/?abcdefg1111111111111111111111

https://www.google.com/pg/adiddas/?abcdefg1111111111111111111111

https://www.google.com/pg/vans/?abcdefg1111111111111111111111

https://www.google.com/pg/converse/?abcdefg1111111111111111111111

the output should be like this:

https://www.google.com/pg/nike/

https://www.google.com/pg/adiddas/

https://www.google.com/pg/vans/

https://www.google.com/pg/converse/

above code is not working that there's missing in the code. however if i use the selection it worked but i want both functionality to be used.

here's the code that works:

Sub removeExcess_domain()
Dim cell As Range
Dim MyRange As Range
Dim tmp As String


Set MyRange = Selection  'this is your range of data

'loop through every cell in range and remove characters after ?
For Each cell In MyRange.Cells
    tmp = cell.Value
    '
    cell.Value = Left(tmp, InStr(tmp, "?") - 1)
Next
End Sub

Thanks for your reply,
Mike

 

[Michael M]

The code works fine for me but selecting an entire column would mean running the process through 65000 rows....Do you really want to do that ??
Maybe this way..select the entire column, but it finds the last row of that column first !!

Sub MM1()
Dim cell As Range, MyRange As Range, tmp As String, lr As Long
lr = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
Set MyRange = Range(Cells(2, ActiveCell.Column), Cells(lr, ActiveCell.Column)) 'this is your range of data
'loop through every cell in range and remove characters after ?
On Error Resume Next
For Each cell In Range(Cells(2, ActiveCell.Column), Cells(lr, ActiveCell.Column))
    tmp = cell.Value
    cell.Value = Left(tmp, InStr(tmp, "?") - 1)
Next cell
End Sub

 

[Mike TheSpike]

@Michael M
Perfect! Thanks a lot. you save my day my friend.

 

[Mike TheSpike]

@Michael M
By the way, is it okay to put specific column like column(L) rather on ActiveCell.Column?
In this case whenever my active cell it will always execute the column "L" .
i'm having difficulty in that column. Thanks again.

 

[Mike TheSpike]

@Michael M
Sorry for the follow up above. I figured it out on how to make it happen.
it is just a simple "On Error Resume Next"
Thanks to you! you're great.

 

[Michael M]

Glad to help...

 

[Rick Rothstein]

Assuming the question mark always starts your excess junk and that you have selected one or more cells in the column you want to process, only one line of code is needed to do what is wanted...

Sub ShortenURL()
  ActiveCell.EntireColumn.Replace "~?*", "", xlPart, , , , False, False
End Sub

If you want to specify the column directly, then use this line of code instead of the one I posted above...

  Columns("L").Replace "~?*", "", xlPart, , , , False, False

Note: You do not have to worry about the code processing the entire column as Replace seems to only look at the UsedRange.

 

[Mike TheSpike]

@Rick
OMG! Amazing. this is a short code and fast run of macro. both of your codes is amazing and i am using it now.
Thanks to both of you.