Can't go on to the next page

[Marc L]

Thanks !

Yes it's better to release from memory all variables objects
by setting them to Nothing before procedure exit …

For readers, previous code use early binding for request object,
reference Microsoft XML 6.0 checked within project.

From previous code, a demontration to extract only names
with filled emails in late binding way (no need any reference) :​

Sub Demo2()
         Const URL = "http://www.sportfocus.com/comdir/morekeywords.cfm?cid=11&maj=cricket&ckid=102&min=clubs and Associations&kid=860&key=England"
    With CreateObject("Msxml2.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "DNT", "1"
        .send "type=name&rowlimit=999&count=1"
         SPQ = Split(.responseText, "<dt><a href=")
    End With
    If UBound(SPQ) > 0 Then
       ReDim VA$(1 To UBound(SPQ), 1)
        For R& = 1 To UBound(SPQ)
                      SP = Split(SPQ(R), "<a href=""mailto:")
            If UBound(SP) > 0 Then
                      L& = L& + 1
                VA(L, 0) = Split(Split(SP(0), ">")(1), "<")(0)
                VA(L, 1) = Split(SP(1), """")(0)
            End If
        Next
            ActiveSheet.UsedRange.Offset(1).Clear
            [A2].Resize(L, 2).Value = VA
    End If
End Sub

VA$() means VA() As String
R& is same as R As Long
To see in VBA inner help in variables types but
it is easier to use Dim statement in top of procedure …
​

 

[shahin]

Dear Marc L, I'm not good at writing Array either. But, I'm gonna learn it today as far as I can. So, meanwhile one more thing I need to know. If in my messy code I would like to use "if block" in place of "On Error Resume Next", how will it look like. I hope it is possible, by the way. For better understanding off course. Thanks in advance.

 

[Marc L]

You already had all the necessary in my first demonstration !​

Sub ExtractingEmail()
  Const URL = "http://www.sportfocus.com/comdir/morekeywords.cfm?cid=11&maj=cricket&ckid=102&min=clubs%20and%20Associations&kid=860&key=England"
    Dim http As New MSXML2.XMLHTTP60, x As Long, str() As String, i As Long, SP$()
        x = 2
        http.Open "Post", URL, False
        http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        http.send "type=name&rowlimit=999&count=1"
        str = Split(http.responseText, "<dt><a href=")
        Set http = Nothing
    For i = 1 To UBound(str)
        SP = Split(str(i), "<a href=""mailto:")
        Cells(x, 1).Value = Split(Split(SP(0), ">")(1), "<")(0)
        If UBound(SP) > 0 Then Cells(x, 2).Value = Split(SP(1), """")(0)
        x = x + 1
    Next i
End Sub

Just compare with my Demo1 procedure …
​

 

[shahin]

Thanks a ton. Very happy now. Long live the Marc L!

 

[Marc L]

To achieve this thread, for HTML purists, a way using htmlfile object,
just by exploring in Locals window oElt object !​

Sub Demo3()
        Const URL = "http://www.sportfocus.com/comdir/morekeywords.cfm?cid=11&maj=cricket&ckid=102&min=clubs and Associations&kid=860&key=England"
          Dim oDoc As Object, oDes As Object, oElt As Object, VA$(), R&
    With CreateObject("Msxml2.XMLHTTP")
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "DNT", "1"
         On Error Resume Next
        .send "type=name&rowlimit=999&count=1"
         On Error GoTo 0
        If .Status = 200 Then
          Set oDoc = CreateObject("htmlfile")
              oDoc.write .responseText
        End If
    End With
    If Not oDoc Is Nothing Then
           ActiveSheet.UsedRange.Offset(1).Clear
           Set oDes = oDoc.getElementsByTagName("DL")
           ReDim VA(1 To oDes.Length, 1)
        For Each oElt In oDes
              If oElt.Children.Length > 1 Then
                             R = R + 1
                      VA(R, 0) = oElt.Children(0).innerText
                With oElt.Children(1).Children
                    If .Length Then
                        With .Item(.Length - 1)
                          If .tagName = "A" Then VA(R, 1) = Replace$(.href, "mailto:", "")
                        End With
                    End If
                End With
              End If
        Next
                  [A2].Resize(R, 2).Value = VA
            Set oDes = Nothing:  Set oDoc = Nothing
    End If
End Sub

Needing more time to code than previous via romana …
Same result as Demo1.
​

 

[shahin]

Tried the way Marc L taught me except for "On Error Resume Next".

Sub ExtractingEmail()
Const URL = "http://www.sportfocus.com/comdir/morekeywords.cfm?cid=11&maj=cricket&ckid=102&min=clubs%20and%20Associations&kid=860&key=England"
Dim html As New HTMLDocument
Dim topics As Object, topic As Object

With New MSXML2.XMLHTTP60
    .Open "Post", URL, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .setRequestHeader "DNT", "1"
    .send "type=Name&rowlimit=730&count=1"
    html.body.innerHTML = .responseText
End With
Set topics = html.getElementsByTagName("dt")
    On Error Resume Next
    For y = 0 To topics.Length - 7
        x = x + 1
        Cells(x, 1) = topics(y).getElementsByTagName("a")(0).innerText
        Cells(x, 2) = Split(topics(y).NextSibling.getElementsByTagName("a")(0).href, "mailto:")(1)
    Next y
Set html = Nothing
End Sub

 

[Marc L]

What is the purpose of Topic object variable ? Nothing !
You forgot to release Topics object variable …

Without On Error statement :​

Sub ExtractingEmail()
Const URL = "http://www.sportfocus.com/comdir/morekeywords.cfm?cid=11&maj=cricket&ckid=102&min=clubs%20and%20Associations&kid=860&key=England"
Dim oDoc As New HTMLDocument, topics As Object, oRef As Object, y&, x&

With New MSXML2.XMLHTTP60
    .Open "POST", URL, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .setRequestHeader "DNT", "1"
    .send "type=name&rowlimit=999&count=1"
     oDoc.body.innerHTML = .responseText
End With
    Set topics = oDoc.getElementsByTagName("DL")
    ActiveSheet.UsedRange.Clear
For y = 0 To topics.Length - 7
   Set oRef = topics(y).getElementsByTagName("a")
    If oRef.Length Then
        x = x + 1
        Cells(x, 1).Value = oRef(0).innerText
        If oRef.Length > 1 Then Cells(x, 2).Value = Replace(oRef(1).href, "mailto:", "")
    End If
Next y
    Set oDoc = Nothing:  Set topics = Nothing:  Set oRef = Nothing
End Sub

 

[shahin]

Now I have learned how to avoid on error resume next. Thanks again Marc L. You are really the gem. Btw, topic has got no meaning to be used. I use this stuff to avoid writing as i use it oftentimes. I'll not practice it.