从网站提取html数据,关于从指定网页上提取数据并汇总整理的求助-CSDN博客

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

Set tb2 = Nothing

End With

If k > 0 Then

Range("A2").Resize(k, 19) = arr2

MsgBox "完成共 " & k & " 个"

End If

End Sub