Private Sub CommandButton1_Click()
'Columns for both tables
Const colUrl As Long = 1 'Must always be the first column
Const colmail As Long = 2 'Must always be the first column before Some platforms
Const colFacebook As Long = 3 'Must always be the last column of Some platforms
Const colError As Long = 4 'Must always be the last column
Dim url As String, http As Object, htmlDoc As Object, nodeAllLinks As Object
Dim nodeOneLink As Object, pageLoadSuccessful As Boolean
Dim tbl_url_oal As String, tbl_all As String, currentRowTableUrls As Long, lastRowTableUrls&
Dim currentRowsTableAll(colUrl To colFacebook) As Long
Dim lastRowTableAll As Long, addressCounters(colmail To colFacebook) As Long
Dim checkCounters As Long, cel As Range
tbl_url_oal = "foglio2" 'Name of Sheet
currentRowTableUrls = 2 'First row for content
tbl_all = "Sheet1" 'Name of Sheet
Sheets(tbl_url_oal).Activate
With New XMLHTTP60
On Error Resume Next
For Each cel In Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row)
.Open "GET", cel.Value, False
.send
If .Status = 200 Then cel.Offset(, 1).Value = Split(Split(.responseText, "<title>")(1), "</")(0)
Next
End With
For checkCounters = colUrl To colFacebook
currentRowsTableAll(checkCounters) = 2 'First rows for content
Next checkCounters
Set htmlDoc = CreateObject("htmlfile")
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'Delete all rows except headline in the sheet with all addresses
lastRowTableAll = Sheets(tbl_all).Cells(Rows.Count, colUrl).End(xlUp).Row
Sheets(tbl_all).Rows(currentRowsTableAll(colUrl) & ":" & lastRowTableAll).Delete Shift:=xlUp
'Loop over all URLs in column A in the URL source sheet
Do While Sheets(tbl_url_oal).Cells(currentRowTableUrls, 1).Value <> ""
'Scroll for visual monitoring, if 'the sheet with the URLs are the
If ActiveSheet.Name = tbl_url_oal Then
If currentRowTableUrls > 14 Then
ActiveWindow.SmallScroll down:=1
End If
Sheets(tbl_url_oal).Cells(currentRowTableUrls, 1).Select
End If
'Get next url from the URL source sheet
url = Sheets(tbl_url_oal).Cells(currentRowTableUrls, colUrl).Value
'Try to load page 'Temporarily disable error handling if 'there is a timeout or onother error
On Error Resume Next
http.Open "GET", url, False
http.send
'Check if page loading was successful
If Err.Number = 0 Then
pageLoadSuccessful = True
End If
On Error GoTo 0
If pageLoadSuccessful Then
'Build html document for DOM operations
htmlDoc.body.innerHTML = http.responseText
'Create node list from all links of the page
Set nodeAllLinks = htmlDoc.getElementsByTagName("a")
'Walk through all links of the node list
For Each nodeOneLink In nodeAllLinks
DoEvents
'Write mail address to both tables
Sheets(tbl_url_oal).Cells(currentRowTableUrls, colmail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
Sheets(tbl_all).Cells(currentRowsTableAll(colmail), colmail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
'Check if it is a new line in the sheet with all addresses
If currentRowsTableAll(colmail) >= currentRowsTableAll(colUrl) Then
'Write URL in the new line of the sheet with all addresses
Sheets(tbl_all).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
'Increment url counter
currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
End If
'Increment mail counters
currentRowsTableAll(colmail) = currentRowsTableAll(colmail) + 1
addressCounters(colmail) = addressCounters(colmail) + 1
Next nodeOneLink
'Check address counters
For checkCounters = colmail To colFacebook
'Set comment if more than 1 link were found
If addressCounters(checkCounters) > 1 Then
End If
Next checkCounters
Else
End If
'Prepare for next page
pageLoadSuccessful = False
Erase addressCounters
lastRowTableAll = Sheets(tbl_all).Cells(Rows.Count, colUrl).End(xlUp).Row
For checkCounters = colUrl To colFacebook
currentRowsTableAll(checkCounters) = lastRowTableAll + 1 'First rows for next page content
Next checkCounters
currentRowTableUrls = currentRowTableUrls + 1
Loop
'Clean up
Set http = Nothing: Set htmlDoc = Nothing
Set nodeAllLinks = Nothing
Set nodeOneLink = Nothing
Dim r As Range, c
Sheets("Sheet1").Activate
[b1] = "header"
[c1] = [b1]
For c = 4 To Sheets("Foglio2").[3:3].Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
[c2] = "*" & Sheets("Foglio2").Cells(3, c) & "*"
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("c1:c2"), CopyToRange:=[e1], Unique:=True
Set r = [e1].CurrentRegion
Set r = Range(Cells(2, 5), Cells(r.Rows.Count, 5))
If Len([e2]) Then r.Copy Sheets("Foglio2").Cells(4, c)
r.Delete
Next
End Sub
