如何转换网页图片数据，获取到EXCEL表中呢？

westwindgg · 发表于 2014-9-2 21:28

请问附件，目前 E-G行因原网站为图片故获取不到数据，请问可否修改代码，使原图片不同颜色图片转化成不同数值，（比如没有灯为0，有黄色灯为1，绿色灯值为2，灰色灯为3）而存到相应列里面呢？

求助各位大侠！

westwindgg · 发表于 2014-9-3 10:32

求助！这个有难度吧

suwenkai · 发表于 2014-9-3 11:09

代码在03版本，xp系统下运行正常。

Sub test()
Dim url, html
url = "http://www.cde.org.cn/transparent.do?method=spxlList&tasktype=xb&nowYearM=2014-04&acceptid=&applyTypeCde=IND&isTimetag=0&pageMaxNumber=360&pagenum=1"
Set html = CreateObject("htmlfile")
n = 2
ar = [{"序号","受理号","进入中心时间","审评状态","药理毒理","临床","药学","备注"}]
Cells.ClearContents
Range("a2").Resize(1, UBound(ar)) = ar
With CreateObject("msxml2.xmlhttp")
.Open "get", url, False
.send
html.body.innerhtml = .responsetext
Set tb = html.all.tags("tr")
For i = 0 To tb.Length - 1
If tb(i).bgcolor = "#f5fafe" Then
n = n + 1
For j = 0 To 3
Cells(n, j + 1) = tb(i).Cells(j).innertext
Next
Cells(n, 8) = tb(i).Cells(7).innertext
For j = 4 To 6
If InStr(tb(i).Cells(j).innerhtml, "lamp_shut.gif") > 0 Then
Cells(n, j + 1) = "灯灭"
ElseIf InStr(tb(i).Cells(j).innerhtml, "lamp_y.jpg") Then
Cells(n, j + 1) = "黄灯"
ElseIf InStr(tb(i).Cells(j).innerhtml, "lamp.gif") Then
Cells(n, j + 1) = "绿灯"
End If
Next
Else
End If
Next
End With
End Sub

复制代码

westwindgg · 发表于 2014-9-3 15:33

非常感谢suwenkai ，如果想继续获取数据，即将B列受理号为关键词，从以下网址中的搜索结果，分别列于I列~R列，应该如何改代码呢？？
http://app1.sfda.gov.cn/datasear ... olumnName=COLUMN464,COLUMN475&title=药品注册进度查询

企业名称办理状态状态开始时间通知时间标准品回执收到日收费情况费用收到日检验报告收到日药品批准文号通知内容

westwindgg · 发表于 2014-9-3 17:41

求助高手们？

suwenkai · 发表于 2014-9-3 18:46

试用了一下批量查询，可能会卡死。

Sub test()
Dim url, html
url = "http://www.cde.org.cn/transparent.do?method=spxlList&tasktype=xb&nowYearM=2014-04&acceptid=&applyTypeCde=IND&isTimetag=0&pageMaxNumber=360&pagenum=1"
Set html = CreateObject("htmlfile")
n = 2
ar = [{"序号","受理号","进入中心时间","审评状态","药理毒理","临床","药学","备注","受理号","企业名称","办理状态","状态开始时间","通知时间","标准品回执收到日","收费情况","费用收到日","检验报告收到日","药品批准文号","通知内容"}]
Cells.ClearContents
Range("a2").Resize(1, UBound(ar)) = ar
With CreateObject("msxml2.xmlhttp")
.Open "get", url, False
.send
html.body.innerhtml = .responsetext
Set tb = html.all.tags("tr")
For i = 0 To tb.Length - 1
If tb(i).bgcolor = "#f5fafe" Then
n = n + 1
For j = 0 To 3
Cells(n, j + 1) = tb(i).Cells(j).innertext
Next
Cells(n, 8) = tb(i).Cells(7).innertext
For j = 4 To 6
If InStr(tb(i).Cells(j).innerhtml, "lamp_shut.gif") > 0 Then
Cells(n, j + 1) = "灯灭"
ElseIf InStr(tb(i).Cells(j).innerhtml, "lamp_y.jpg") Then
Cells(n, j + 1) = "黄灯"
ElseIf InStr(tb(i).Cells(j).innerhtml, "lamp.gif") Then
Cells(n, j + 1) = "绿灯"
End If
Next
strNO = Cells(n, 2)
ar = get_url(strNO)
Cells(n, 9).Resize(1, 11) = ar
End If
Next
End With
End Sub
Public Function get_url(strNO)
Dim url, html, postData, arr(1 To 12)
url = "http://app1.sfda.gov.cn/datasearch/schedule/search.jsp?"
url = url & "tableId=43&tableName=TABLE43&columnName=COLUMN464,COLUMN475"
url = url & "&title=%E8%8D%AF%E5%93%81%E6%B3%A8%E5%86%8C%E8%BF%9B%E5%BA%A6%E6%9F%A5%E8%AF%A2"
url = url & "&code=" & strNO
Set html = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
.Open "get", url, False
.send
html.body.innerhtml = .responsetext
Set tb = html.all.tags("tr")
For i = 24 To 34
n = n + 1
arr(n) = tb(i).Cells(1).innertext
Next
End With
get_url = arr
End Function

复制代码

westwindgg · 发表于 2014-9-4 18:22

谢谢。运行时真是卡死了

westwindgg · 发表于 2014-9-4 19:18

非常感谢，明白了，如果想再继续在T列~Y列加以下数据呢，即如果想继续以B列受理号为关键词，从以下网址中的搜索结果，分别列于T列~Y列，应该如何改代码呢？？
http://www.cde.org.cn/news.do?me ... p;pageName=service#
万分感谢啊

westwindgg · 发表于 2014-9-5 16:37

再顶下，有人能帮助下吗？

ak47ok · 发表于 2014-9-6 06:07

suwenkai 发表于 2014-9-3 18:46
试用了一下批量查询，可能会卡死。

请教老师：可能会卡死，是指网站不能刷新过快、还是数据量太多？

		自动登录	找回密码
密码			免费注册

[求助] 如何转换网页图片数据，获取到EXCEL表中呢？

评分

评分

最新热点 /1