URL Search

[Sharid]

Hi

I hope someone can help, I'm a bit stuck

At work I have a large list of url in sheet1 column A, when i click on the url a page opens up in the browser and there is another url on that page that i need, this lead to external site. I want this url to be extracted and go into column B, hopefully without the browser opening everytime as there are over 6000 url

e.g.
URL = h ttps://www.MYwebsite.com when this opens i want the URL that states https://www.Yourwebsite.com to be extracted and go in to column B

The macro then moves onto the next url, if there is more than 1 url on that page then it places it in to column C and then D and so on

Is this possible, otherwise I have to do it by hand.

 

[Sharid]

Hi

I'm look for something simmilar to this https://www.youtube.com/watch?v=MswEPIFTEVU this works on the url in the first row, I wanted them in first column. I downlaoded this but can't seem to get it to work. Can someone please have a look. You can downlaod it from a link in YouTube.

Thanks

 

[Sharid]

Hi

I'm still stuck on this one, I have found this code on the web, which extracts web data and puts it into excel. the problem is this -

1) I have over 6000 url I need it to pull the url from sheet1 column1, then move to the next url

2) I need it to only pull URL from that web page and paste it into column B, if there is more than 1 url then it goes into Column C, D, E

This code seems to pull everything and then paste it into excel, but not row by row, as there are many blank rows between the text

Sub Test()
Dim IE As Object

Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.Navigate "http://www.aarp.org/" ' should work for any URL
Do Until .ReadyState = 4: DoEvents: Loop

x = .document.body.innertext
x = Replace(x, Chr(10), Chr(13))
x = Split(x, Chr(13))
Range("A1").Resize(UBound(x)) = Application.Transpose(x)

.Quit
End With

End Sub

 

[Sharid]

Hi

I have put this code together using other codes, It kind of does what I want. It gets all the URL from a web page and then paste them in excel. What I need it to do is

Use the url from a list on sheet 2 column A there are 6000 url and paste the results in Sheet1 Column A under next blank row, deleting any duplicates in sheet 1

Also it opens the browser but does not close it, this has to be done manually.


Currently it will only seach 1 URL in this case BBC and paste the results in Sheet1 column A, If another url is input it does not paste the results in the next blank row, it will just override the BBC results. The browser does not auto close and I can't do this for 6000 url manually

Sub webpage()
Dim internet As InternetExplorer
Dim internetdata As HTMLDocument
Dim internetlink As Object
Dim internetinnerlink As Object

Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = True
internet.navigate ("https://www.bbc.co.uk/")
Do While internet.Busy
DoEvents
Loop

Do Until internet.READYSTATE = READYSTATE_COMPLETE

DoEvents
Loop
Set internetdata = internet.document
Set internetlink = internetdata.getElementsByTagName("a")
i = 1
For Each internetinnerlink In internetlink

ActiveSheet.Cells(i, 1) = internetinnerlink.href
i = i + 1

Next internetinnerlink


' deletes duplicates in column A
Dim rCell As Range
Dim rRange As Range
Dim lCount As Long

Set rRange = Range("A1", Range("A" & Rows.Count).End(xlUp))
lCount = rRange.Rows.Count

For lCount = lCount To 1 Step -1
With rRange.Cells(lCount, 1)
If WorksheetFunction.CountIf(rRange, .Value) > 1 Then
.EntireRow.Delete
End If
End With
Next lCount

End Sub

Thanks for having a look

 

[Sharid]

Hi

I'm still stuck on this one, I have changed the code and it work much better, still having a few problems these are -

1) To use the url from a list on sheet 2 column A there are 6000 url and paste the results in Sheet1 Column A under next blank row, currently it only works on 1 URL

Private Sub CommandButton2_Click()
' +++++++++++++++ FOR url extraction ++++++++++++++++

Dim IE, items, elem As Object
Dim i, j, k, l As Integer

i = 2
k = 2
l = 2

Set IE = CreateObject("Internetexplorer.application")

IE.Visible = True

IE.navigate "https://www.bbc.co.uk"

Do While IE.busy Or IE.readyState <> 4

Loop

For i = 0 To 500
On Error Resume Next

Range("A" & i).Value = IE.document.getelementsbytagname("a").Item(i).innerText

Next i
IE.Visible = Quit

' Deletes duplicates in column A
Columns(1).RemoveDuplicates Columns:=Array(1)


End Sub

Please can someone help, I really stuck on this one

 

[Sharid]

I have got the code working so it pastes into another sheet, I changed it from


THIS
Range("A" & i).Value = IE.document.getelementsbytagname("a").Item(i).innerText


TO THIS
Sheets("Sheet1").Range("A" & i).Value = IE.document.getelementsbytagname("a").Item(i).innerText



Now it pastes the results into, the problem Im still having is,

1) It does not paste the NEW data into the NEXT blank row, it just ove writes the first data

2) Still can't pull from urls list from sheet 2

could someone have a look, please

 

[Sharid]

I can get this code to open URL LIST in Sheet2, the problem is

1) it opens in my default browser and not the IE object

2) It opens all the URL in tabs at once, so if there are 10 url it will open 10 tabs, 100 url will equal 100 tabs at once.

I can't get this code to work with my code, so it opens in IE 1 page at a time, copies the data and then closes the IE then opens the next URL and repeats the process. My above code does all the coping and closing the IE, this code opens urls from sheet 2 which are in column A.



Dim Cell As Range
Set LinkRng = Sheets("Sheet2").Range("A1").CurrentRegion.Columns(1)
On Error Resume Next
For Each Cell In LinkRng.Cells
Cell.Hyperlinks(1).Follow
Next
On Error GoTo 0

Please can someone have a look

 

[Sharid]

Look like i have worked out the bulk of it, this is my code, here is what it does :-

1) Opens a url from sheet2 column 1 in IE
2) Code copies all URL from that site to Sheet1 Column1 and then closes IE
3) Deletes any duplicates in Sheet1 column 1

What I need it to do now is

1) Loop this process, go back to Sheet2 Column1 and get the next URL and keep repeating this process until there are no more urls in the column
2) Paste the new date in sheet1 column1 under next empty row.

Private Sub CommandButton2_Click()
' +++++++++++++++ FOR url extraction ++++++++++++++++

Dim ie, items, elem As Object
Dim i, j, k, l As Integer

i = 2
k = 2
l = 2

On Error Resume Next

Set ie = CreateObject("InternetExplorer.Application")

ie.Navigate Sheets("Sheet2").Range("A1").Value
ie.Visible = True
Application.Wait (Now + TimeValue("00:00:10"))

Do While ie.busy Or ie.readyState <> 4

Loop

For i = 0 To 500
On Error Resume Next

Sheets("Sheet1").Range("A" & i).Value = ie.document.getelementsbytagname("a").Item(i).innerText

Next i
ie.Visible = Quit

' Deletes duplicates in column A
Columns(1).RemoveDuplicates Columns:=Array(1)

End Sub


Please can someone have a look, im really stuck on the last 2 things

Also this code times IE Application.Wait (Now + TimeValue("00:00:10")) and then closes it, would it be possible, that once the links have been copied it auto closes IE.

 

[Sharid]

I'm still stuck on this one can someone help me out please

I have a Command Button on Sheet1 and a List of URL in Sheet2 Column A. When the command button is clicked my code takes the first URL from Sheet2 Column A, opens IE and then imports the URL from that page into Sheet1 Column A, then closes IE and deletes any duplicates, this bit is fine . I can't get it to do this : -

1) I need the code to repeat but this time go to the next url in Sheet2 and do the same, the code does this until no more URL are left on Sheet2

2) It pastes the new date in the next blank row, currently it over writes the previous data.

Private Sub CommandButton2_Click()

'For url extraction
Dim IE, items, elem As Object
Dim i, j, k, l As Integer

i = 2
k = 2
l = 2

'Create IE open it for said time, get url from sheet
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate Sheets("Sheet2").Range("A1").Value
Application.Wait (Now + TimeValue("00:00:5"))

Do While IE.Busy Or IE.ReadyState <> 4

Loop

For i = 0 To 500
On Error Resume Next

'Paste in sheet and column
Sheets("Sheet1").Range("A" & i).Value = IE.Document.getElementsByTagName("a").Item(i).innerText

'Close IE Browser
Next i
IE.Visible = Quit

'Deletes duplicates in column A
Columns(1).RemoveDuplicates Columns:=Array(1)


End Sub

 

[Sharid]

Hi

I have updated my code so it loops through the url on Sheet2, I only tested on 3 URL and it worked. The problems Im having are as such: -

1) Data is not pasted into Sheet1 next blank row, all new data is pasted into Sheet1 column 1 starting in cell A1. I can't work out the code for pasting into next blank row

2) IE will not close after last url is done

3) MOST IMPORTANT in task manager the IE is still running even though code has stapped and the IE is draining a lot of memory, pc fan sound increases

new code

Private Sub CommandButton2_Click()

Dim i, j, k, l As Integer

i = 2
k = 2
l = 2

'SHEET2 as sheet with URL
Dim wsSheet As Worksheet, Rows As Long, links As Variant, IE As Object, link As Variant
Set wb = ThisWorkbook
Set wsSheet = wb.Sheets("Sheet2")

'Set IE = InternetExplorer
Set IE = CreateObject("InternetExplorer.Application")
Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
links = wsSheet.Range("A1:A" & Rows)

'IE Open Time per page 5sec and check links on Sheet2 Column A
With IE
.Visible = True
Application.Wait (Now + TimeValue("00:00:5"))

For Each link In links
.navigate (link)
While .Busy Or .ReadyState <> 4: DoEvents: Wend

For i = 0 To 500
On Error Resume Next

'Paste in sheet and column
Sheets("Sheet1").Range("A" & i).Value = IE.Document.getElementsByTagName("a").Item(i).innerText

Next i

'Deletes duplicates in column A Sheet1
Columns(1).RemoveDuplicates Columns:=Array(1)

'navigate links
Next link

End With

'Close IE Browser
IE.Visible = Quit

End Sub

Can some please help.