Macro to trim text in cell with condition

[V51773]

Hello All,

Im looking into learning how to macro all the cells say in column A to remove the following from a website entry, example http://www.PubHorn01.com.ar or https://www.PubHorn01.com.ar or www.PubHorn01.com, http://www.PubHorn01.com/adasdasd, now i've tried using find and replace then recording it as a macro, but my problem is the data is not constant, i just want my end result to be .PubHorn01.com.ar, but again that raises another issue some website just ends with .com , some website has .com.ph , au , ar etc . so the condition must be itll keep both .com.xx and .com. and it would also ignore not make any changes to correct format entries.

from this data

http://www.PubHorn01.com/asasasasas

http://PubHorn01.com/asasasasas

https://www.PubHorn01.com.ar/asasas/asasasa

www.PubHorn01.com.xx/
www.PubHorn01.tk
www.PubHorn01.info
PubHorn01.info

expected results is

PubHorn01.com
PubHorn01.com.ar
PubHorn01.com.xx
PubHorn01.tk
PubHorn01.info
PubHorn01.info

 

[Dan_W]

Hi, I know you said that the data is not constant , but there does seem to be a recurring pattern which makes it pretty straight forward I hope. Please see below a function which can be called from another macro or can be called from the worksheet:

Function CleanURL(ByVal Target As String) As String
    Dim StartChar As Long, EndChar As Long
    StartChar = InStr(1, Target, "Pub", vbTextCompare)
    EndChar = InStr(StartChar + 1, Target, "/", vbTextCompare)
    If EndChar > 0 Then
        CleanURL = Mid(Target, StartChar, EndChar - StartChar)
    Else
        CleanURL = Mid(Target, StartChar)
    End If
End Function

From the Worksheet this can be called:

=CleanURL(A1)

or from VBA:

Dim TrimmedURL As String
TrimmedURL = CleanUrl(SampleURL)

I hope that helps, but let me know if any of the above doesn't make sense.

 

[V51773]

Hello Dan,

Thank you for your reply, for some reason the above code is giving me a #value error. also i have one more condition needed.
entry
www.john.blogspot.com

output
john.blogspot.com

Thank you,
Mike

 

[mohadin]

Hi
Too late to modify
so
Try

Sub test()
    Dim a As Variant
    Dim i As Long
    a = Range("A2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
    With CreateObject("VBScript.RegExp")
        .Pattern = "([\A-Z\.])\w+[\.\w+]+\w+"
        For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            a(i, 1) = .Execute(a(i, 1))(0)
            If (Left(a(i, 1), 1)) = "." Then a(i, 1) = Mid(a(i, 1), 2, 255)
            End If
        Next
    End With
    Cells(2, 2).Resize(UBound(a)) = a
End Sub

Updated

 

[V51773]

Hello Mohadin,

its working but it pulls up a bad result for www.john.blogspot.com, only comes out as blogspot.com

Thank you

 

[mohadin]

Have you seen the updated version
Please copy the code in post #6 again
If you have errors again please post more of the examples

 

[mohadin]

Strange it works OK in here!!!

Sub test()
    Dim a As Variant
    Dim i As Long
    a = Range("A2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
    With CreateObject("VBScript.RegExp")
        .Pattern = "([\A-Z\.])\w+[\.\w+]+\w+"
        For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            a(i, 1) = .Execute(a(i, 1))(0)
            If (Left(a(i, 1), 1)) = "." Then a(i, 1) = Mid(a(i, 1), 2, 255)
            End If
        Next
    End With
    Cells(2, 2).Resize(UBound(a)) = a
End Sub

 

[V51773]

Hello Mohadin,

Thank you for your reply, one last pproblem im getting is , if the query is just john.blogspot.com, it still alters it and comes out as blogspot.com.

Thank you so much for your help.

 

[mohadin]

 

[V51773]

Hi Mohadin,

This is what i meant.

Thank you for your help