|
|
上旋下弦月大师 指点了最关键的部分,感谢!
代码部分有点乱. 不好意思. 你先试用下.
Sub test2()
Dim i As Integer, j As Integer, xmlhttp As Object, k As Long, n As Integer, tmp, tm, d, Arr, Pos As Long, Pos1 As Long, SearchString As String, SearchChar As String
Dim Strzm As String, Ii As Long, Strzmh As String, Iii As Long, strst As String, tempstring As String, addflag As Integer, totalnum As Long, xpos As Long, ypos As Long
Dim string1 As String, string2 As String
Set d = CreateObject("Scripting.Dictionary")
k = 3
addflag = 0
ypos = Range("A65536").End(xlUp).Row
xpos = [IV3].End(xlToLeft).Column + 1
Arr = Range("a3:a" & ypos + 3)
If ypos > 5 Then
For i = 1 To ypos
d(Arr(i, 1)) = i + 2
Next i
End If
[a2:c2] = Split("股票名称,股票代码,市盈率", ",")
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
With xmlhttp
.Open "get", "http://quotes.money.163.com/hs/service/diyrank.php?page=0&count=2200&sort=PERCENT&order=desc&query=STYPE:EQA&fields=CODE,SYMBOL,SNAME,PRICE,PERCENT,UPDOWN,OPEN,YESTCLOSE,HIGH,LOW,VOLUME,TURNOVER,HS,LB,PE,MCAP,TCAP,MFRATIO.MFRATIO14,MFRATIO.MFRATIO2,MFRATIO.MFRATIO10,ANNOUNMT,UVSNEWS&type=query&callback=callback_1685702196", False
.send
End With
SearchString = StrConv(xmlhttp.responsebody, vbUnicode, &H804)
SearchString = Replace(SearchString, """", "")
SearchString = Replace(SearchString, ":", ",")
tm = Split(SearchString, "CODE,")
For i = 1 To UBound(tm) - 1
SearchChar = "OPEN,"
Pos = InStr(tm(i), SearchChar)
SearchChar = "PERCENT,"
Pos1 = InStr(tm(i), SearchChar)
If Pos1 - Pos < 15 Then
tm(i) = Replace(tm(i), "PERCENT,", "PE,-,PERCENT,")
End If
tmp = Split(tm(i), ",")
n = 1
If tmp(2) > 0 Then ' 当前的数据要是无效时,不录入表格
For j = 0 To 36
'Debug.Print tmp(j)
If n = 1 Then
string1 = tmp(j) '股票代码 填入表格
' ElseIf n = 22 Then
'string2 = Left(tmp(j), 6) ' 市盈率 填入表格
End If
If ypos > 5 Then
If tmp(j) = "PE" Then
string2 = Left(tmp(j + 1), 6) ' 市盈率 填入表格
Debug.Print string2
ElseIf tmp(j) = "SNAME" Then
On Error Resume Next
tempstring = tmp(j + 1)
SearchChar = "\u"
Pos = InStr(tempstring, SearchChar)
addflag = 0
If Pos > 1 Then
addflag = 1
SearchString = Left(tempstring, Pos - 1)
tempstring = Right(tempstring, Len(tempstring) - Pos + 1)
End If
Strzm = Replace(tempstring, "\u", "")
For Iii = 1 To Len(Strzm) Step 4
Strzmh = Strzmh + ChrW(CInt("&H" & Mid(Strzm, Iii, 4)))
Next
If addflag = 1 Then
Strzmh = SearchString & Strzmh
End If
' Cells(k, 1).Value = Strzmh
Debug.Print Strzmh
'x = Arr(i, 1)
If Not d.exists(Strzmh) Then
ypos = ypos + 1
d(Arr(ypos, 1)) = ypos
Cells(ypos, 1).Value = Strzmh ' 汉字部分 填入表格
Cells(ypos, 2).Value = string1 ' 股票代码 填入表格
Cells(ypos, xpos).Value = string2 ' 市盈率 填入表格
Debug.Print 8; Strzmh; d(Strzmh); xpos; string2
Else
Cells(d(Strzmh), xpos).Value = string2 ' 市盈率 填入表格
Debug.Print Strzmh; d(Strzmh); xpos; string2
End If
Strzmh = ""
End If
'------------------------------------------------
Else
If n = 1 Then
Cells(k, 2).Value = tmp(j) '股票代码 填入表格
ElseIf n = 22 Then
'Cells(k, 3).Value = tmp(j) ' 市盈率 填入表格
' Cells(k, 3).Value = Left(tmp(j), 6) ' 市盈率 填入表格
End If
'------------------------------------------------ 汉字解码部分 ' 汉字部分 填入表格
If tmp(j) = "PE" Then
Cells(k, 3).Value = Left(tmp(j + 1), 6) ' 市盈率 填入表格
ElseIf tmp(j) = "SNAME" Then
On Error Resume Next
tempstring = tmp(j + 1)
SearchChar = "\u"
Pos = InStr(tempstring, SearchChar)
addflag = 0
If Pos > 1 Then
addflag = 1
SearchString = Left(tempstring, Pos - 1)
tempstring = Right(tempstring, Len(tempstring) - Pos + 1)
End If
Strzm = Replace(tempstring, "\u", "")
For Iii = 1 To Len(Strzm) Step 4
Strzmh = Strzmh + ChrW(CInt("&H" & Mid(Strzm, Iii, 4)))
Next
If addflag = 1 Then
Strzmh = SearchString & Strzmh
End If
Cells(k, 1).Value = Strzmh
Strzmh = ""
' Cells(k, 1).Value = tmp(j + 1)
End If
'------------------------------------------------
End If
n = n + 1
Next
k = k + 1
End If
Next
Set d = Nothing
End Sub |
评分
-
1
查看全部评分
-
|
楼主: zjykdada
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-6-30 11:47
楼主
