Extract parts of urls to build a new link

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
I have a list of urls in Sheet2 column C, starting from row 2 down. I need to extract parts of the url and change it. In the image below I need the part in Blue.

From
1617795684586.png

1617795844157.png


I need the NEW urls to replace the urls in Column C and NOT to put the results into A NEW Column as my code below does. It also stripping the wrong part of the url, as it Stripped the word YellowPages and NOT the bit shown above in blue

VBA Code:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
            Set ws = wb.Sheets("URLs")
        ''' STRIP A DOMAIN
            ws.Range("D2:D" & ws.Range("C" & Rows.Count).End(xlUp).Row).Formula = "=TRIM(MID(SUBSTITUTE(C2,""."",REPT("" "",999)),999,999))"
        ''' STRING Url Maker
            ws.Range("E2:E" & ws.Range("D" & Rows.Count).End(xlUp).Row).Formula = "=(""https://www.""&SUBSTITUTE(D2, "" "", """")&""/"")"

Sorry but had to post urls as images as they kept turning in to links. I have been stuck on this for a few days now and can not work it out as I am not good a I would prefer it with vba or a formula. Vba if possible as it works faster

1617797560734.png
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
I was able to do some of it like this, however I can not remove the bits in yellow (%2F and after)

VBA Code:
Command Button1_Click
  Dim X As Long, Parts As Variant, PartsTwo As Variant
            For X = 1 To Cells(Rows.Count, "c").End(xlUp).Row
            Parts = Split(Cells(X, "c").Value, "F%2F") 'remove this F%2F AND anything before
            Cells(X, "c") = Parts(1)
            'PartsTwo = Split(Cells(X, "c").Value, "%2F") ' remove this %2F AND anything AFTER
            'Cells(X, "c") = PartsTwo(1)
 Next
End Sub

1617811128682.png
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
I have managed to fix most parts of this now, I am just stuck on the final part. Its not the best code, but it works for now.

With the following I can extract the part of the url that I need and convert it to a domain as long as it has the www. if it does not then I can not convert it to a domain. see image below for more details. This is the bit I am now stuck on.

VBA Code:
  Set wb = ThisWorkbook
        Set wsSheet = wb.Sheets("YP")
        'sort urls out in column C
        Dim X As Long, Parts As Variant, PartsTwo As Variant
            For X = 1 To wsSheet.Cells(Rows.Count, "c").End(xlUp).Row
            Parts = Split(wsSheet.Cells(X, "c").Value, "F%2F")    '''remove this F%2F AND anything before
            wsSheet.Cells(X, "c") = Parts(1)
            Parts = Split(wsSheet.Cells(X, "C").Value, "%")       '''remove this % AND anything AFTER
            wsSheet.Cells(X, "C") = Trim(Parts(0))
       Next
       With wsSheet.Range("C:C")
            .Replace "www.", "https://www."      '''replace all www. with https:/www.
            ''.Replace "", "https://www."
       End With

Any strings that DO NOT have the www. I can not convert as show below in yellow

1617973898547.png
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
503
Office Version
  1. 2010
Platform
  1. Windows
Unclear but anyway a demonstration as a beginner starter :​
VBA Code:
Sub Demo1()
        Dim V, R&, S$()
    With Sheet2.UsedRange.Columns(3)
            V = .Value2
        For R = 2 To .Rows.Count
            S = Split(V(R, 1), "%2F")
            If UBound(S) > 0 Then V(R, 1) = "https://" & S(UBound(S) - 1)
        Next
           .Value2 = V
    End With
End Sub
 
Solution

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,054
Office Version
  1. 2016
Platform
  1. Windows
Super Just what I was after, thanks Marc L
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
503
Office Version
  1. 2010
Platform
  1. Windows
You're welcome and thanks for your Like, my first in this forum ‼​
 

Watch MrExcel Video

Forum statistics

Threads
1,129,713
Messages
5,637,936
Members
416,993
Latest member
ant8989

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top