[已解决]网页提取问题 提示错误

hanjia

zjdh 教授 帮忙写的     在这先谢谢  zjdh
把网址改成下面这几个就都不好使了   请帮忙改一下   谢谢
http://www.1396.me/xyft/kaijiang
http://www.1396b.com/xync/kaijiang
http://www.1396.me/shishicai/kaijiang

Sub 飞艇开奖()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"   '飞艇开奖
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("飞艇开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 9
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub
Sub 农场开奖()
    Dim url, html
    url = "http://www.1396b.com/xync/kaijiang"  '农场开奖
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("农场开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            Cells(W + 1, 2) = Left(Replace(Cells(W + 1, 2), " ", ","), 23)
        End If
    Next
End Sub
Sub 重庆开奖()
    Dim url, html
    url = "http://www.1396.me/shishicai/kaijiang"  '重庆开奖
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("重庆开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            Cells(W + 1, 2) = Left(Replace(Cells(W + 1, 2), " ", ","), 23)
        End If
    Next
End Sub
   网页提取数据.rar (14.54 KB, 下载次数: 9)

2015-6-21 21:37 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

scl5801

2015-6-21 21:59

hanjia 发表于 2015-6-21 21:54
什么意思？ 能说清楚点吗    谢谢

Sub 飞艇()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"   '飞艇
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("飞艇开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 9
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub
Sub 农场()
    Dim url, html
    url = "http://www.1396b.com/xync/kaijiang"  '农场
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("农场开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 6
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 7
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub
Sub 重庆()
    Dim url, html
    url = "http://www.1396.me/shishicai/kaijiang"  '重庆
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("重庆开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 8
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            Cells(W + 1, 2) = Left(Replace(Cells(W + 1, 2), " ", ","), 23)
        End If
    Next
End Sub
Sub 清空()
    Range("a2:j65536").ClearContents
End Sub

跳转到最佳答案楼层

liziyuliziyu7

农场   For J = 0 To 6

重庆    For J = 0 To 8

飞艇     For J = 0 To 9

hanjia

liziyuliziyu7 发表于 2015-6-21 21:50
农场   For J = 0 To 6

重庆    For J = 0 To 8

什么意思？ 能说清楚点吗    谢谢

scl5801

hanjia 发表于 2015-6-21 21:54
什么意思？ 能说清楚点吗    谢谢

Sub 飞艇()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"   '飞艇
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("飞艇开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 9
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub
Sub 农场()
    Dim url, html
    url = "http://www.1396b.com/xync/kaijiang"  '农场
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("农场开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 6
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 7
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub
Sub 重庆()
    Dim url, html
    url = "http://www.1396.me/shishicai/kaijiang"  '重庆
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("重庆开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 8
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            Cells(W + 1, 2) = Left(Replace(Cells(W + 1, 2), " ", ","), 23)
        End If
    Next
End Sub
Sub 清空()
    Range("a2:j65536").ClearContents
End Sub

hanjia

scl5801 发表于 2015-6-21 21:59
Sub 飞艇()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"   '飞艇

是对的    谢谢
有一条不知道怎么回事   点击提取他不会提取最新数据
网页以经更新数据了   点击提取他不会更新数据
要重新打开表格才会提取最新数据

Sub 飞艇开奖()
    Dim url, html
    url = "http://www.1396.me/xyft/kaijiang"   '飞艇开奖
    Set html = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url, False
        .send
        html.body.innerhtml = .responsetext
    End With
    Set TR = html.all.tags("tr")
    Sheets("飞艇开奖").Select
    清空
    For I = 0 To TR.Length - 1
        If TR(I).classname = "odd" Or TR(I).classname = "even" Then
            W = W + 1
            For J = 0 To 9
                Cells(W + 1, J + 1) = Replace(TR(I).ChildNodes(J).OuterText, vbCrLf, " ")
            Next
            KJ = ""
            For S = 0 To 9
                KJ = KJ & "," & Replace(TR(I).ChildNodes(1).ChildNodes(S).classname, "pk-no", "")
            Next
            Cells(W + 1, 2) = Mid(KJ, 2)
        End If
    Next
End Sub