学习网页数据提取

zzq0101

作者 ExcelHome -ldy  转载请保留 此文的全部或部分欢迎贴在网页上，但要印在纸上，我会上门要版权
http://www.17u.cn/tianqi/qingdaotianqiyubao_292.html" '网址


  Sub test01()
[a1].CurrentRegion.ClearContents
Cells.NumberFormat = "@"
Set ie1 = UserForm1.WebBrowser1
With ie1
  .navigate "http://www.17u.cn/tianqi/qingdaotianqiyubao_292.html" '网址
  Do Until .readyState = 4
    DoEvents
  Loop
  Set dmt = .document
End With
For i = 0 To dmt.all.Length - 1
If i = 150 Or i = 161 Or i = 172 Then
t = t + 1
        Set htMent = dmt.all(i)
        Cells(t, "A") = htMent.innerText
        End If
    Next i
End Sub

用ldy 老师的工具查出来的，然后点数出来的  150  161  172  （所在行数）凑出来的，呵呵！
该贴已经同步到 zzq0101的微博

zzq0101

chuhaiou   老师的代码
Sub a()
    Dim ie1 As Object, dmt As Object, r As Object, i As Long, j As Long
    'Load UserForm1
    'UserForm1.Show 0
    [a1].CurrentRegion.Clear
    Cells.NumberFormat = "@"
    Set ie1 = UserForm1.WebBrowser1
    With ie1
        .Navigate "http://qq.ip138.com/weather/shandong/qingdao.htm"    '网址
        Do Until .ReadyState = 4
            DoEvents
        Loop
        Set dmt = .Document
    End With
    Application.ScreenUpdating = False
    Set r = dmt.All.tags("table")(3).Rows    '40白天
    For i = 0 To r.Length - 1
        For j = 0 To r(i).Cells.Length - 1
            Cells(i + 1, j + 1) = r(i).Cells(j).innerText
        Next
    Next
    Application.ScreenUpdating = True
    Set ie1 = Nothing
    Set dmt = Nothing
    Set r = Nothing
    [a1].CurrentRegion.Columns.AutoFit
End Sub

很典型的例子 代码，可做样板的！

zzq0101

MSXML2.XMLHTTP.3.0   的方式读取网页
Sub test02()
Range("a1:a200").ClearContents
    Dim html As MSHTML.HTMLDocument
    Dim tables As MSHTML.HTMLTable
    Dim rows As MSHTML.HTMLTableRow
    Dim HttpReq As Object
    Set HttpReq = CreateObject("MSXML2.XMLHTTP.3.0")
    With HttpReq
        .Open "GET", "http://www.17u.cn/tianqi/qingdaotianqiyubao_292.html", False
        .send
        sTot = HttpReq.responseText
        bStr = InStr(sTot, """week fontVerdana""")
        eStr = InStr(sTot, """tqbottom""")
        tStr = Mid(sTot, bStr, eStr - bStr + 1)
        taryStr = Split(tStr, "</div>")
        For i = 0 To UBound(taryStr)
            ar = Split(Replace(Replace(taryStr(i), vbCrLf, ""), "  ", ""), """>")
            aaa = UBound(ar)
            If aaa <> -1 Then
                bbb = ar(aaa)
                If Left(bbb, 1) <> "<" Then
                    t = t + 1
                    Cells(t, 1) = bbb
                End If
            End If
        Next
    End With

End Sub

自己瞎写的，提取所有的代码，然后找到自己需要的，纯粹是凑出来的，呵呵！

zzq0101

xmyjk  老师的代码

Sub test03()

Dim ie1 As Object, dmt As Object, r As Object, i As Long, j As Long
'Load UserForm1
'UserForm1.Show 0
[a1].CurrentRegion.Clear
Cells.NumberFormat = "@"
Set ie1 = UserForm1.WebBrowser1
With ie1
  .navigate "http://ball365.net/newo/mpk.html?ct=1317477534001" '网址
  Do Until .readyState = 4
    DoEvents
  Loop
  Set dmt = .document
End With
Application.ScreenUpdating = False
Set r = dmt.all.tags("table")(35).rows
For i = 0 To r.Length - 1
   For j = 0 To r(i).Cells.Length - 1
        Cells(i + 1, j + 1) = r(i).Cells(j).innerText
   Next
Next
Application.ScreenUpdating = True
Set ie1 = Nothing
Set dmt = Nothing
Set r = Nothing
[a1].CurrentRegion.Columns.AutoFit
End Sub

Set r = dmt.all.tags("table")(35).rows  就是第36个表格，因为从0 开始的！

zzq0101

QueryTables.Add 方法
Sub test04()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://qq.ip138.com/weather/shandong/QingDao.htm", Destination:=Range( _
        "A1"))
        .Name = "QingDao"
        .PreserveFormatting = True
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .AdjustColumnWidth = True
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "4"
        .Refresh BackgroundQuery:=False
    End With
End Sub

此代码是先录制，数据-导入外部数据-新建WEB查询 -有个提示（让你选择需要导入的表格，点击后会变成对号的）   后再改的代码！

wenwu0318

学习了，谢谢楼主！

zzq0101

按理说  InternetExplorer.Application  的应用和一楼的一样，但在我的微机上死机，不知为什么？   一楼的运行正常！

Sub test05()
Set IE = CreateObject("InternetExplorer.Application")
    IE.navigate "http://www.17u.cn/tianqi/qingdaotianqiyubao_292.html"
    IE.Visible = False 'False不起作用？浏览器时不时会激活，气人。。。
    Do Until IE.readyState = READYSTATE_COMPLETE
        DoEvents
    Loop
     Set dmt = IE.document

For i = 0 To dmt.all.Length - 1
If i = 150 Or i = 161 Or i = 172 Then
t = t + 1
        Set htMent = dmt.all(i)
        Cells(t, "A") = htMent.innerText
        End If
    Next i
    Set IE = Nothing
End Sub

据说速度慢的！但我的死机不动，可能代码错误，或我没有耐心的原因吧！

jiminyanyan

zzq0101 发表于 2012-5-29 21:37
按理说  InternetExplorer.Application  的应用和一楼的一样，但在我的微机上死机，不知为什么？   一楼的运 ...

i 值就3个数,没必要外循环了吧......

zzq0101

CreateObject("Microsoft.XMLDOM")   的方法！

Function GetStockAllData(ByRef StockCode As String)
     On Error Resume Next
     If Len(StockCode) <> 6 Then Exit Function
    '判断上证还是深证
    If Left(StockCode, 2) = 60 Or Left(StockCode, 2) = 58 Then
        StockCode = "sh" & StockCode
    ElseIf Left(StockCode, 2) = 0 Or Left(StockCode, 2) = 3 Then
        StockCode = "sz" & StockCode
    Else
        StockCode = "sh600000"
    End If

    Dim iData As String
    iData = Format(Month(Date), "00")
    iData = iData & Format(Day(Date), "00")
    iData = Year(Date) & iData
    StockCode = "http://biz.finance.sina.com.cn/stock/flash_hq/kline_data.php?symbol=" & StockCode
    StockCode = StockCode & Chr(38) & "end_date=" & iData
    StockCode = StockCode & Chr(38) & "begin_date=20100101"
    '开始读取XML内容
    Dim XML, objNode, objAtr As Object
    Dim nCntChd, nCntAtr As Long
    Set XML = CreateObject("Microsoft.XMLDOM")
    With XML
        .async = False
        .Load (StockCode)
    End With
    Set objNode = XML.documentElement
    nCntChd = objNode.ChildNodes.Length - 1 'XML的记录个数
    Dim arrA
    ReDim arrA(0 To nCntChd, 0 To 6)
    '开始遍历
    For i = 0 To nCntChd
        Set objAtr = objNode.ChildNodes.Item(i)
        nCntAtr = objAtr.Attributes.Length - 1
        For j = 0 To nCntAtr '遍历一条记录里面的所有的记录项，记录是从0开始的
            arrA(i, j) = objAtr.Attributes.Item(j).Text
        Next j
    Next i
    Set objAtr = Nothing
    Set objNode = Nothing
    Set XML = Nothing
    If Err.Number > 0 Then MsgBox ("查不到股票信息")
    Err.Clear
    On Error GoTo 0
    GetStockAllData = arrA
End Function

zzq0101

jiminyanyan 发表于 2012-5-29 22:14
i 值就3个数,没必要外循环了吧......

是的，当时写的时候我想 提取5天或7天的 天气预报的，后来发现比较麻烦，就放弃了！
回个头来 发现 就三个值 ，没必要循环了。  第一 懒的再改代码  第二 我以后循环查找其他数据 范例代码，也就没再改了！