url = "http://data.eastmoney.com/aspx/data.aspx?name=RptOrganizationPositions&orgType=Intrust&reportDate=20141231&page=1&pageSize=550&sortType=2&sortRule=-1&jsname=DoSLVGvD&changeType=All%20"
s = "股票代码,股票简称,持有信托家数,持股总数,占总股本比例,持股变动数值,持股变动比例,持仓明细,持仓市值变动值"

txt = getText(url)
txt = Replace(txt, """,""", vbLf)
arr = Split(Split(txt, """")(1), vbLf)

For i = 0 to UBound(arr)
        a = Split(arr(i), ",")
        url = "http://data.eastmoney.com/aspx/data.aspx?name=jgcgdetail&orgType=Xintuo&reportDate=20141231&page=1&pageSize=50&sortType=2&sortRule=-1&jsname=pDPZhTqy&codes=" & a(0) & a(7) & "%20"
        a(7) = RegEx(getText(url))
        ReDim Preserve a(8)
        If a(5) <> "-" and a(7) <> "-" and a(3) <> "-" Then
                a(8) = FormatNumber(a(5) * a(7) / a(3), 2, true)
        Else a(8) = "-"
        End If
        arr(i) = Join(a, ",")
Next

s = s & vbCrLf & Join(arr, vbCrLf)

Set fso = CreateObject("Scripting.FileSystemObject")
''fso.OpenTextFile("1.csv", 2, true).Write s
fso.OpenTextFile("1.xls", 2, true).Write Replace(s, ",", vbTab)

MsgBox "OK"

Function getText(ByVal url)
        Set http = CreateObject ("Microsoft.XMLHTTP")
        http.Open "GET", url, false
        http.Send
        getText = http.responseText
End Function

Function RegEx(txt)
        Set re = New RegExp
        re.Pattern = ",信托,[^,]*,([\d\.]+),"
        re.Global = true
        If Not re.Test(txt) Then RegEx = "-" : Exit Function
        For Each m in re.Execute(txt)
                n = n + 0 + m.SubMatches(0)
        Next
        RegEx = n
End Function
复制代码

WScript.Sleep 1000
复制代码