stefanoste78
Member
Combine multiple codes in the same module with the creation of buttons to start each single code.
I need to combine several codes as indicated in the title.
it is necessary to add to the code in the "links" file the code for extracting the name of the web page (file scrape title) and the code that you place here:
thanks
I need to combine several codes as indicated in the title.
it is necessary to add to the code in the "links" file the code for extracting the name of the web page (file scrape title) and the code that you place here:
Code:
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
thanks