|
除非注明，文章均为 战战如疯 原创，转载请保留链接: http://www./cat3/96.html，VBA交流群273624828。
今天我们再来看一个用Excel VBA下载新浪财经数据的例子。我们要下载的是机构持股汇总数据http://vip.stock.finance.sina.com.cn/q/go.php/vComStockHold/kind/jgcg/index.phtml，我们可以看到这个页面中的年度和季度是有下拉框选择的，如果要达到这样的效果我们也需要在Excel中作出相应的下拉框并对应相应的参数，如何做下拉框并分析对应参数我们之后再讲，本节我们只提取2014年中报数据。看下面的代码
Sub 机构持股汇总()
Dim winhttp, URL, i, j, t1, k, d, code, c, oDoc, n, r, y, m, f, arr1, h, jd
Sheet1.UsedRange.ClearContents
Sheet1.Activate
Sheet1.Columns(1).NumberFormatLocal = "@"
Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Set oDoc = CreateObject("htmlfile")
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
arr1 = Array("证券代码", "证券简称", "机构数", "机构数变化", "持股比例（%）", "持股比例增幅（%）", "占流通股比例（%）", "占流通股比例增幅（%）")
Sheet1.[a1].Resize(1, 8) = arr1
With winhttp
For c = 1 To 60
URL = "http://vip.stock.finance.sina.com.cn/q/go.php/vComStockHold/kind/jgcg/index.phtml?symbol=%D6%A4%C8%AF%BC%F2%B3%C6%BB%F2%B4%FA%C2%EB&reportdate=2014&quarter=2&p=" & c
Application.StatusBar = "正在获取第" & c & "页..."
.Open "GET", URL, False
.setRequestHeader "Connection", "Keep-Alive"
.send
t1 = BytesToBstr(.ResponseBody, "GB2312")
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '调试用，数据放入剪贴板
.SetText t1
.PutInClipboard
End With
oDoc.body.innerhtml = t1
n = [a65536].End(xlUp).Row + 1
h = 0
On Error GoTo 100
Set r = oDoc.all.tags("table")(0).Rows
Dim arr
ReDim arr(1 To Round(r.Length / 2), 1 To r(1).Cells.Length - 1)
For i = 1 To r.Length - 1 Step 2
h = h + 1
For j = 0 To r(i).Cells.Length - 2
arr(h, j + 1) = r(i).Cells(j).innertext
Next j
Next i
Range("a" & [a1048576].End(xlUp).Row + 1).Resize(r.Length / 2, r(1).Cells.Length - 1) = arr
Erase arr
Next c
End With
'Sheet1.Columns(5).Delete
100
Sheet1.UsedRange.Columns.AutoFit
Sheet1.UsedRange.HorizontalAlignment = xlCenter
Set winhttp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Function BytesToBstr(strBody, CodeBase) '使用Adodb.Stream对象提取字符串
Dim objStream
On Error Resume Next
Set objStream = CreateObject("Adodb.Stream")
With objStream
.Type = 1 '二进制
.Mode = 3 '读写
.Open
.Write strBody '二进制数组写入Adodb.Stream对象内部
.Position = 0 '位置起始为0
.Type = 2 '字符串
.Charset = CodeBase '数据的编码格式
BytesToBstr = .ReadText '得到字符串
End With
objStream.Close
Set objStream = Nothing
If Err.Number <> 0 Then BytesToBstr = ""
On Error GoTo 0
End Function
这个网址数据的采集也是GET方法，并不涉及POST，但其中涉及到了转码，Function BytesToBstr(strBody, CodeBase)是ExcelHome网友liucaq提取的转码代码，我直接拿来用了。因为网页中的数据是以表格形式出现的，所以我这里用了html的方法取得表格中的数据。本文的示例文件下载地址http://pan.baidu.com/s/1dD5rTZV
|
