Private Sub CommandButton1_Click()
Const colUrl As Long = 1 'Must always be the first column
Dim url$, http As Object, htmlDoc As Object, nodeAllLinks As Object, onelink As Object, loadOK As Boolean, _
tbl_url_oal$, tbl_all As String, cr_tbl_urls As Long, lastRowTableUrls&, cr_table_all(1 To 3) As Long, _
lastRowTableAll&, cc As Long, cel As Range
tbl_url_oal = "foglio1" 'Name of Sheet
cr_tbl_urls = 2 'First row for content
tbl_all = "foglio1"
Sheets(tbl_url_oal).Activate
For cc = colUrl To 3
cr_table_all(cc) = 2
Next
Set htmlDoc = CreateObject("htmlfile")
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
Do While Sheets(tbl_url_oal).Cells(cr_tbl_urls, 1) <> ""
If Not Sheets(tbl_url_oal).Cells(cr_tbl_urls, 1).Font.Bold Then
If ActiveSheet.Name = tbl_url_oal Then Sheets(tbl_url_oal).Cells(cr_tbl_urls, 1).Activate
url = Sheets(tbl_url_oal).Cells(cr_tbl_urls, 1)
On Error Resume Next
http.Open "GET", url, False
http.send
If Err.Number = 0 Then loadOK = True
On Error GoTo 0
If loadOK Then
htmlDoc.body.innerHTML = http.responseText
Set nodeAllLinks = htmlDoc.getElementsByTagName("a")
cr_table_all(1) = Sheets(tbl_all).Range("b" & Rows.Count).End(xlUp).Row + 1
For Each onelink In nodeAllLinks
DoEvents
Sheets(tbl_all).Cells(cr_table_all(1), 2) = _
Right(onelink.href, Len(onelink.href) - InStr(onelink.href, ":"))
Sheets(tbl_all).Cells(cr_table_all(1), 3) = url
cr_table_all(1) = cr_table_all(1) + 1
Next
End If
loadOK = False
lastRowTableAll = Sheets(tbl_all).Cells(Rows.Count, colUrl).End(xlUp).Row
For cc = colUrl To 3
cr_table_all(cc) = lastRowTableAll + 1
Next
Sheets(tbl_url_oal).Cells(cr_tbl_urls, 1).Font.Bold = True
End If
cr_tbl_urls = cr_tbl_urls + 1
Loop
Set http = Nothing: Set htmlDoc = Nothing
Set nodeAllLinks = Nothing
Set onelink = Nothing
End Sub