转：VBA操作网页读取数据自动填入EXCEL表中

http://wenku.baidu.com/view/10ca5457f01dc281e53af01f.html

 Sub a正式查分程序()
        '运行时会出现错误提示，中止程序，更改j初值后重新运行
       Dim ie, dmt
       Dim i, j, k, bb, nianfen As Integer
       Dim text1 As String       '存储考号
       Dim text2 As String       '存储报名序号
       Dim text3 As String       '存储浏览器地址
       Dim fuwuqi As String      '存储服务器地址
       Dim tijiao As String      '存储提交命令
       nianfen = 2012            '存储年份，每年更改“2012”
       fuwuqi = "http://218.28.109.125:81/cjcx/tmp_cx_zzcj.php"   '自行更改为可用服务器
       tijiao = "&cmdok=ȷ��"                             'cmdok=ȷ��为提交命令
       bb = Sheet3.Range("a65536").End(xlUp).Row                  '计算当前工作表sheet3的有效行数，需自行更改“sheet3”
      ' On Error Resume Next
      '主程序
      k = 0
      For j = 2 To bb                 '循环变量从2到sheet2最后一行，出错后起始值改为当前行
        k = k + 1                        '
             If k > 20 Then              '每20行，可以增大“20”数值
             ActiveWorkbook.Save         '自动保存
             ActiveWindow.ScrollRow = j  '自动滚屏到当前行
             k = 0                       '循环变量清零
             End If
        text1 = Cells(j, 1)              '从当前行第一列读取考号，根据情况调整列“1”数值
        text2 = Cells(j, 2)              '从当前行第二列读取报名序号，根据情况调整列“2”数值
        '生成查询地址
        text3 = fuwuqi & "?textdate=" & nianfen & "&textkh=" & text1 & "&textzjhm=" & text2 & tijiao
        '创建网页对象
        Set ie = CreateObject("InternetExplorer.Application")
             With ie
                 .Visible = False            '网页设置为不可见
                 .Navigate text3             '导航到查询网址并提交
                 'On Error Resume Next
                 ' MsgBox text3
                 'Sleep 10000                'sleep库函数未用
                 Do Until .ReadyState = 4    '等网页完全打开
             DoEvents
             Loop
             Set dmt = .Document             '读取查询服务器返回内容
             '网页内容处理
             i = 0        '循环变量清零
             For Each td In dmt.getElementsByTagName_r("td")       '查找网页代码

内的文本填充到当前行的第i+5列，根据要求适当调整i+5的值
                   End If
             Next
                .Quit                        '关闭网页
             Set dmt = Nothing               'DMT对象清空
             End With
      Next j
      Set ie = Nothing                       'IE对象清空

 

      [s2].CurrentRegion.Columns.AutoFit     '设置为自动填充
  End Sub
 

i = i + 1                    If i > 13 Then                                '第13个TD后为分数                    Cells(j, 5 + i) = td.innerText                '每个