[已解决]网页字段导出问题

huianbao100

网页局部字段导入，详见附件，能打开网址的交易策略下面文字导入excel，

最佳答案

月排行榜 / 总排行榜

suye1010

2013-10-31 23:39

1. Option Explicit
   
2. Sub ExtractData()
   
3. On Error Resume Next
   
4. Dim i, arr0, arr
   
5. arr0 = Range(Cells(2, 3), Cells(Cells(65536, 3).End(xlUp).Row, 4))
   
6. For i = 1 To UBound(arr0)
   
7. arr0(i, 2) = Split(Split(Split(GetCode("UTF-8", arr0(i, 1)), "//交易策略")(3), "{")(1), "}")(0)
   
8. arr = Split(Replace(arr0(i, 2), """", ""), ",")
   
9. arr0(i, 2) = Replace(arr(2), "    ", vbCrLf)
   
10. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(6), "    ", vbCrLf)
    
11. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(5), "    ", vbCrLf)
    
12. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(4), "    ", vbCrLf)
    
13. Erase arr
    
14. Next i
    
15. Cells(2, 3).Resize(UBound(arr0), 2) = arr0
    
16. MsgBox "数据提取完成"
    
17. End Sub
    
18. Function GetCode(CodeBase, Url) '第一个参数是设置编码方式(GB2312或UTF-8)第二个参数是地址.
    
19. Dim xmlHTTP
    
20. Set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
    
21. xmlHTTP.Open "get", Url, True
    
22. xmlHTTP.send
    
23. While xmlHTTP.ReadyState <> 4
    
24. DoEvents
    
25. Wend
    
26. GetCode = xmlHTTP.ResponseBody
    
27. If CStr(GetCode) <> "" Then GetCode = BytesToBstr(GetCode, CodeBase)
    
28. Set xmlHTTP = Nothing
    
29. End Function
    
30.   Function BytesToBstr(strBody, CodeBase)
    
31. Dim ObjStream
    
32. Set ObjStream = CreateObject("Adodb.Stream")
    
33. With ObjStream
    
34. .Type = 1
    
35. .Mode = 3
    
36. .Open
    
37. .write strBody
    
38. .Position = 0
    
39. .Type = 2
    
40. .Charset = CodeBase
    
41. BytesToBstr = .ReadText
    
42. .Close
    
43. End With
    
44. Set ObjStream = Nothing
    
45. End Function

复制代码

问题.zip (285.58 KB, 下载次数: 4, 售价: 5 个金币)

2013-10-31 23:39 上传

点击文件名下载附件

跳转到最佳答案楼层

suye1010

1. Option Explicit
   
2. Sub ExtractData()
   
3. On Error Resume Next
   
4. Dim i, arr0, arr
   
5. arr0 = Range(Cells(2, 3), Cells(Cells(65536, 3).End(xlUp).Row, 4))
   
6. For i = 1 To UBound(arr0)
   
7. arr0(i, 2) = Split(Split(Split(GetCode("UTF-8", arr0(i, 1)), "//交易策略")(3), "{")(1), "}")(0)
   
8. arr = Split(Replace(arr0(i, 2), """", ""), ",")
   
9. arr0(i, 2) = Replace(arr(2), "    ", vbCrLf)
   
10. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(6), "    ", vbCrLf)
    
11. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(5), "    ", vbCrLf)
    
12. arr0(i, 2) = arr0(i, 2) & vbCrLf & Replace(arr(4), "    ", vbCrLf)
    
13. Erase arr
    
14. Next i
    
15. Cells(2, 3).Resize(UBound(arr0), 2) = arr0
    
16. MsgBox "数据提取完成"
    
17. End Sub
    
18. Function GetCode(CodeBase, Url) '第一个参数是设置编码方式(GB2312或UTF-8)第二个参数是地址.
    
19. Dim xmlHTTP
    
20. Set xmlHTTP = CreateObject("Microsoft.XMLHTTP")
    
21. xmlHTTP.Open "get", Url, True
    
22. xmlHTTP.send
    
23. While xmlHTTP.ReadyState <> 4
    
24. DoEvents
    
25. Wend
    
26. GetCode = xmlHTTP.ResponseBody
    
27. If CStr(GetCode) <> "" Then GetCode = BytesToBstr(GetCode, CodeBase)
    
28. Set xmlHTTP = Nothing
    
29. End Function
    
30.   Function BytesToBstr(strBody, CodeBase)
    
31. Dim ObjStream
    
32. Set ObjStream = CreateObject("Adodb.Stream")
    
33. With ObjStream
    
34. .Type = 1
    
35. .Mode = 3
    
36. .Open
    
37. .write strBody
    
38. .Position = 0
    
39. .Type = 2
    
40. .Charset = CodeBase
    
41. BytesToBstr = .ReadText
    
42. .Close
    
43. End With
    
44. Set ObjStream = Nothing
    
45. End Function

复制代码

问题.zip (285.58 KB, 下载次数: 4, 售价: 5 个金币)

2013-10-31 23:39 上传

点击文件名下载附件