Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1528|回复: 6

[已解决]求助网页中提取数据

[复制链接]
发表于 2013-5-12 23:58 | 显示全部楼层 |阅读模式
我想在http://lishi.tianqi.com/jiangjin/201211.html 这个网页中提取这个月每天的天气情况 求详解能让我知道怎么才能查找到我自己需要的数据
最佳答案
2013-5-13 00:01
c40天气预报.rar (19.25 KB, 下载次数: 25)
发表于 2013-5-13 00:01 | 显示全部楼层    本楼为最佳答案   
c40天气预报.rar (19.25 KB, 下载次数: 25)
回复

使用道具 举报

发表于 2013-5-13 07:19 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2013-5-13 07:45 | 显示全部楼层
hwc2ycy 发表于 2013-5-13 00:01

高难 学习 最佳你值得拥有
回复

使用道具 举报

发表于 2013-5-13 08:02 | 显示全部楼层
我心飞翔410 发表于 2013-5-13 07:45
高难 学习 最佳你值得拥有

这已经是最最简单的提取了,
基本上就是对字符串的处理,没有别的技巧。
回复

使用道具 举报

发表于 2013-5-13 08:44 | 显示全部楼层
本帖最后由 hwc2ycy 于 2013-5-22 15:22 编辑

你用这个,配合记事本。
split函数你看看帮助,也好理解的。
  1. Sub 查询天气()

  2.     Dim strDate$
  3.     Dim strUrl$
  4.     Dim strText$
  5.     Dim strFind$
  6.     Dim arr1, arr2, result(1 To 32, 1 To 6)
  7.     Dim i As Long, j As Byte, k As Byte, m As Byte
  8.     Dim httpRequest As Object

  9.     Dim myClip As Object


  10.     strUrl = "http://lishi.tianqi.com/jiangjin/"
  11.     strDate = Application.InputBox("请输入要查询的年月格式为yyyymm", , Format(Now - Day(Now) - 1, "yyyymm"), , , , , 2)
  12.     If Len(strDate) <> 6 Or Not strDate Like "20*" Then
  13.         MsgBox "查询月份不对"
  14.         Exit Sub
  15.     End If

  16.     '剪贴板对象
  17.     Set myClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  18.     Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
  19.     With httpRequest
  20.         .Open "GET", strUrl & strDate & ".html", False
  21.         .send
  22.         strText = .responseText
  23.     End With

  24.     With myClip

  25.         strFind = "江津" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
  26.         i = InStr(strText, strFind)
  27.         'If UBound(Split(strText, strFind)) = 0 Then
  28.         If i = 0 Then
  29.             MsgBox "查询月份不对"
  30.             Exit Sub
  31.         End If

  32.         '网页原始数据放入剪贴板中
  33.         .SetText strText    '变量
  34.         .PutInClipboard
  35.         MsgBox "1.打开记事本,粘贴" & vbCrLf & "这是原始数据" & _
  36.                  vbCrLf & vbCrLf & "在记事本数据里查找 " & vbCrLf & _
  37.                 strFind & vbCrLf

  38.         strText = Split(strText, strFind)(1)
  39.         '网页原始数据放入剪贴板中
  40.         .SetText strText    '变量
  41.         .PutInClipboard
  42.         MsgBox "2.继续在记事本里粘贴" & vbCrLf & "现在的数据是提取了位于 " & strFind & " 后的所有数据" & _
  43.                 vbCrLf & vbCrLf & "在记事本数据里查找 </div> ,注意第1,2个</div>之间的数据"
  44.         


  45.         strText = Split(strText, "</div>")(1)
  46.         '网页原始数据放入剪贴板中
  47.         .SetText strText    '变量
  48.         .PutInClipboard
  49.         MsgBox "3.继续在记事本里粘贴" & vbCrLf & "现在的数据是提取第1,2个</div>之间的数据" & _
  50.                 vbCrLf & vbCrLf & "在记事本数据里查找 " & "<ul class=""t1"">"
  51.         
  52.         
  53.         strText = Replace(strText, "<ul class=""t1"">", "<ul>")
  54.         
  55.         '网页原始数据放入剪贴板中
  56.         .SetText strText    '变量
  57.         .PutInClipboard
  58.         MsgBox "4.继续在记事本里粘贴" & vbCrLf & "现在 " & "<ul class=""t1""> 已经替换成了 <ul>" & _
  59.                 vbCrLf & "好了,前期数据已经处理完了,剩下的就是利用split函数进行数据的提取了" & _
  60.                 vbCrLf & "如果split懂的话,可以把注释的用LEFT函数的语句打开,F8单步,应该就会明白了。"
  61.                
  62.                
  63.         'Mid(strText, i)
  64.         'i = InStr(Len(strFind) + 20, strText, "</div>")
  65.         'strText = Left(strText, i - 1)
  66.         'strText = Replace(strText, "<ul class=""t1"">", "<ul>")

  67.     End With
  68.    
  69.     arr1 = Split(strText, "<ul>")
  70.     arr2 = Split(arr1(1), "<li>")
  71.     m = m + 1


  72.     '标题
  73.     For k = LBound(arr2) + 1 To UBound(arr2)
  74.         result(m, k) = Split(arr2(k), "<")(0)
  75.         'result(m, k) = Left(arr2(k), InStr(arr2(k), "<") - 1)
  76.     Next

  77.     For j = LBound(arr1) + 2 To UBound(arr1)
  78.         arr2 = Split(arr1(j), "<li>")
  79.         m = m + 1
  80.         
  81.         '第1列日期
  82.         result(m, 1) = Split(Split(arr2(1), ">")(1), "<")(0)
  83.         'result(m, 1) = Mid(arr2(1), InStr(arr2(1), ">") + 1, 10)
  84.         
  85.         '第2列到6列
  86.         For k = LBound(arr2) + 2 To UBound(arr2)
  87.             result(m, k) = Split(arr2(k), "<")(0)
  88.             'result=Left(arr2(k), InStr(arr2(k), "<") - 1)
  89.         Next
  90.     Next

  91.     Application.ScreenUpdating = False

  92.     With Range("a2")
  93.         .CurrentRegion.ClearContents
  94.         .Resize(m, UBound(result, 2)).Value = result
  95.         .CurrentRegion.EntireColumn.AutoFit
  96.     End With
  97.    
  98.     Range("a1").Value = strFind
  99.    
  100.     Application.ScreenUpdating = True
  101.    
  102.     MsgBox "提取完成"
  103. End SuB
复制代码
回复

使用道具 举报

发表于 2013-5-13 11:29 | 显示全部楼层
Sub 查询天气()

    Dim strDate$
    Dim strUrl$
    Dim strText$
    Dim strFind$
    Dim arr1, arr2, result(1 To 32, 1 To 6)
    Dim i As Long, j As Byte, k As Byte, m As Byte


    strUrl = ".weather.com"
    strDate = Application.InputBox("请输入要查询的年月格式为yyyymm", , Format(Now, "yyyymm"), , , , , 2)

    Dim httpRequest As Object
    Set httpRequest = CreateObject("Msxml2.XMLHTTP.3.0")
    With httpRequest
        .Open "GET", strUrl & strDate & ".html", False
        .send
        strText = .responseText
    End With

    strFind = "江津" & Left(strDate, 4) & "年" & Val(Right(strDate, 2)) & "月份天气详情"
    i = InStr(strText, strFind)
    If i = 0 Then
        MsgBox "查询月份不对"
        Exit Sub
    End If

    strText = Mid(strText, i)
    i = InStr(Len(strFind) + 20, strText, "</div>")
    strText = Left(strText, i - 1)
    strText = Replace(strText, "<ul class=""t1"">", "<ul>")

    arr1 = Split(strText, "<ul>")
    arr2 = Split(arr1(1), "<li>")
    m = m + 1
   
    '标题
    For k = LBound(arr2) + 1 To UBound(arr2)
        result(m, k) = Left(arr2(k), InStr(arr2(k), "<") - 1)
    Next

    For j = LBound(arr1) + 2 To UBound(arr1)
        arr2 = Split(arr1(j), "<li>")
        m = m + 1
        result(m, 1) = Mid(arr2(1), InStr(arr2(1), ">") + 1, 10)
        For k = LBound(arr2) + 2 To UBound(arr2)
            result(m, k) = Left(arr2(k), InStr(arr2(k), "<") - 1)
        Next
    Next
    Application.ScreenUpdating = False

    With Range("a2")
        .CurrentRegion.ClearContents
        .Resize(m, UBound(result, 2)).Value = result
        .CurrentRegion.EntireColumn.AutoFit
    End With
    Range("a1").Value = strFind
    Application.ScreenUpdating = True
    MsgBox "提取完成"
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 09:00 , Processed in 0.766958 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表