从网站提取html数据,关于从指定网页上提取数据并汇总整理的求助
Sub Main()
'By:DaWin Date:2017/7/10 六月十七 Monday
' Application.DisplayAlerts = False
' ThisWorkbook.Save
' Application.DisplayAlerts = True
Dim winhttp As Object, k As Long, arr2(1 To 10 ^ 5, 1 To 19) As String
Set winhttp = CreateObject("Msxml2.xmlhttp")
Set Odoc = CreateObject("HTMLFILE")
Set Odoc2 = CreateObject("HTMLFILE")
strURL = "http://www.ciac.sh.cn/XmZtbbaWeb/Gsqk/GsFbList.aspx"
With winhttp
.Open "GET", strURL, False
.send
Odoc.body.innerhtml = .responsetext
VIEWSTATE = Odoc.getelementbyid("__VIEWSTATE").Value
VIEWSTATEGENERATOR = Odoc.getelementbyid("__VIEWSTATEGENERATOR").Value
EVENTVALIDATION = Odoc.getelementbyid("__EVENTVALIDATION").Value
EVENTARGUMENT = "Page$"
EVENTTARGET = "gvList"
Data = "__EVENTTARGET=" & EVENTTARGET _
& "&__EVENTARGUMENT=" & EVENTARGUMENT _
& "&__VIEWSTATE=" & VIEWSTATE _
& "&__VIEWSTATEGENERATOR=" & VIEWSTATEGENERATOR _
& "&__EVENTVALIDATION=" & EVENTVALIDATION _
& "&txtgsrq=" _
& "&txtTogsrq=" _
& "&txttbr=" _
& "&txtzbhxr="
'''''''''''''''''''''''''''''''''''''''''
For Page = 1 To 4
DoEvents
.Open "POST", strURL, False
.send (Replace(Data, EVENTARGUMENT, EVENTARGUMENT & Page))
Odoc.body.innerhtml = .responsetext
Set tb = Odoc.all.tags("Table")(2).Rows
For i = 1 To tb.Length - 2
strVal = Split(Split(tb(i).innerhtml, "ShowGs(")(1), ")")(0)
strValArr = Split(strVal, ",")
If Len(strValArr(1)) > 4 Then
URL = "http://www.ciac.sh.cn/XmZtbbaWeb/Yth/Gsqk/GsFbYth.aspx?zbid=" & strValArr(0)
Else
URL = "http://www.ciac.sh.cn/XmZtbbaWeb/Gsqk/GsFb2015.aspx?zbdjid=&zbid=" & strValArr(0)
End If
.Open "GET", URL, False
.send
strTemp = .responsetext
Odoc2.body.innerhtml = strTemp
Set tb2 = Odoc2.all.tags("Table")(0).Rows
bao_jian_bian_hao = tb2(0).Cells(1).innertext
biao_duan_hao = tb2(0).Cells(3).innertext
zhao_biao_ren = tb2(1).Cells(1).innertext
zhao_biao_dai_li = tb2(2).Cells(1).innertext
lian_xi_ren = tb2(3).Cells(1).innertext
lian_xi_ren_dian_hua = tb2(3).Cells(3).innertext
lian_xi_di_zhi = tb2(4).Cells(1).innertext
lian_xi_ren_you_bian = tb2(4).Cells(3).innertext
zha_biao_fang_shi = tb2(5).Cells(1).innertext
zha_biao_biao_duan_ming_cheng = tb2(6).Cells(1).innertext
zui_gao_biao_jia_xian_jia = " "
he_li_zui_di_jia = " "
xia_fu_bi_li = " "
If InStr(strTemp, "最高投标限价") Then
zui_gao_biao_jia_xian_jia = tb2(7).Cells(1).innertext
he_li_zui_di_jia = tb2(8).Cells(1).innertext
xia_fu_bi_li = Replace(tb2(8).Cells(3).innertext, " ", "")
End If
Set tb2 = Nothing
Set tb2 = Odoc2.all.tags("Table")(1).Rows
If InStr(strTemp, "分项报价") Then
t = 2
Else
t = 1
End If
For r = t To tb2.Length - 2
k = k + 1
arr2(k, 1) = bao_jian_bian_hao
arr2(k, 2) = zhao_biao_ren
arr2(k, 3) = zhao_biao_dai_li
arr2(k, 4) = lian_xi_ren
arr2(k, 5) = lian_xi_di_zhi
arr2(k, 6) = zha_biao_fang_shi
arr2(k, 7) = zha_biao_biao_duan_ming_cheng
arr2(k, 8) = zui_gao_biao_jia_xian_jia
arr2(k, 9) = he_li_zui_di_jia
arr2(k, 10) = biao_duan_hao
arr2(k, 11) = lian_xi_ren_dian_hua
arr2(k, 12) = lian_xi_ren_you_bian
If Len(xia_fu_bi_li) > 1 Then
arr2(k, 13) = xia_fu_bi_li
End If
For c = 0 To tb2(r).Cells.Length - 1
Select Case Replace(Replace(tb2(0).Cells(c).innerhtml, "
", ""), " ", "")
Case "投标人"
arr2(k, 14) = tb2(r).Cells(c).innerhtml
Case "中标候选人排序"
arr2(k, 15) = tb2(r).Cells(c).innerhtml
Case "项目负责人姓名", "总监姓名"
arr2(k, 16) = tb2(r).Cells(c).innerhtml
Case "工期"
arr2(k, 17) = tb2(r).Cells(c).innerhtml
Case "否决投标入围情况", "否决投标/入围情况"
arr2(k, 18) = tb2(r).Cells(c).innerhtml
Case "投标报价(万元)", "投标总报价(万元)"
arr2(k, 19) = tb2(r).Cells(c).innerhtml
Exit For
Case Else
Exit For
End Select
Next
Next
Set tb2 = Nothing
Next
Next
End With
If k > 0 Then
Range("A2").Resize(k, 19) = arr2
MsgBox "完成 共 " & k & " 个"
End If
End Sub