从网上自动下载更新数据到excel

abing3 · 发表于 2011-6-30 11:47

不好意思,我也是菜鸟.  我也没有遇到过的.
刚才百度了一下. 有可能是二个原因.  1. 程序语法错误. 2 .Excel组件有些问题.

这样吧.  我这边是用Excel 2007来测试的,  如果你急的话, 可以先装Excel 2007来试下, 如果不急的话, 等上旋下弦月大师回来帮忙.

abing3 · 发表于 2011-6-30 12:58

刚才看了一个贴子, 上旋下弦月大师有做过这个的. 你可以看一下下面的贴子.
http://club.excelhome.net/thread-702476-1-1.html

abing3 · 发表于 2011-7-1 22:55

代码部分如下.

Sub test()
Dim tmp() As String, i As Integer, arr() As String, xmlhttp As Object, k As Long, N As Long, tmp2 As String, Pos As Long, SearchString As String, SearchChar As String
      k = 2


Cells(1, 1).Value = "股票代码"
Cells(1, 2).Value = "市盈率"
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
With xmlhttp
      .Open "get", "http://quotes.money.163.com/hs/service/diyrank.php?page=0&count=2500&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
   ' tmp = .responsebody
End With

   SearchString = StrConv(xmlhttp.responsebody, vbUnicode, &H804)

While Len(SearchString) > 200

SearchChar = """CODE"":"""
Pos = InStr(SearchString, SearchChar)
SearchString = Right(SearchString, Len(SearchString) - Pos - 7 - 1)

Cells(k, 1).Value = Left(SearchString, 6)

SearchChar = """PE"":"

Pos = InStr(SearchString, SearchChar)

   SearchString = Right(SearchString, Len(SearchString) - Pos - 4)

   SearchChar = ","

Pos = InStr(SearchString, SearchChar)

If Pos > 0 And Pos < 6 Then

   Cells(k, 2).Value = Left(SearchString, Pos - 1)
Else

Cells(k, 2).Value = Left(SearchString, 5)

End If

k = k + 1

Wend

End Sub

xmyjk · 发表于 2011-7-2 00:08

原帖由 abing3 于 2011-7-1 22:55 发表
代码部分如下.

Sub test()
Dim tmp() As String, i As Integer, arr() As String, xmlhttp As Object, k As Long, N As Long, tmp2 As String, Pos As Long, SearchString As String, SearchChar As String
...

做得非常不错，感谢帮忙。

zjykdada · 发表于 2011-7-2 13:07

谢谢 abing3 正是我想要的，如果有时间显示就更好了，比如第一行是1日的市盈率，第二行是2日的市盈率，接下去是3日4日.....我要每天记录下来，abing3能不能再给我编写一下

zjykdada · 发表于 2011-7-6 15:56

上旋下弦月大师，abing3高手，再帮一下忙，谢谢了

abing3 · 发表于 2011-7-6 16:11

你看一下下面的网站上的,不是很好吗?
http://club.excelhome.net/thread-702476-1-1.html

abing3 · 发表于 2011-7-7 10:01

代码部分有点乱. 不好意思. 你先试用下.

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

abing3 · 发表于 2011-7-7 11:13

代码部分如下.

Sub test2()
Dim i As Integer, xmlhttp As Object, 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, tempstring As String, addflag As Integer, xpos As Long, ypos As Long
Dim GP(4) As String
Set d = CreateObject("Scripting.Dictionary")

addflag = 0
ypos = Range("A65536").End(xlUp).Row
xpos = [IV3].End(xlToLeft).Column + 1

  If ypos = 1 Then '当表中为空时, 要确定起始点.
   ypos = 2
  End If

If xpos = 2 Then  '当表中为空时, 要确定起始点.
   xpos = 3
  End If



  Arr = Range("a3:a" & 3000)

  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



GP(0) = Split(Split(tm(i), "SNAME,")(1), ",")(0)    '股票名称
GP(1) = Split(tm(i), ",")(0)                      ' 股票代码
GP(2) = Split(Split(tm(i), "PE,")(1), ",")(0)             ' 股票市盈率
GP(3) = Split(Split(tm(i), "HIGH,")(1), ",")(0)    ' 股票的价格,

If Len(GP(2)) > 6 Then

GP(2) = Left(GP(2), 6)

End If

Strzmh = ""

If GP(3) > 0 Then ' 股票的价格,  如果为0的话, 则股票停牌,不需要考虑.

            '---------------------------解码部分
               On Error Resume Next
            tempstring = GP(0)
            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
            '---------------------------

   If Not d.exists(Strzmh) Then

         ypos = ypos + 1
         d(Arr(ypos, 1)) = ypos
         Cells(ypos, 1).Value = Strzmh  ' 汉字部分填入表格

         Cells(ypos, 2).Value = GP(1) ' 股票代码填入表格
         Cells(ypos, xpos).Value = GP(2) ' 市盈率填入表格

   Else

         Cells(d(Strzmh), xpos).Value = GP(2) ' 市盈率填入表格

   End If

   End If

Next

Set d = Nothing

End Sub

xmyjk · 发表于 2011-7-7 12:35

原帖由 abing3 于 2011-7-7 11:13 发表
代码部分如下.

Sub test2()
Dim i As Integer, xmlhttp As Object, tmp, tm, d, Arr, Pos As Long, Pos1 As Long, SearchString As String, SearchChar As String
Dim Strzm As String, Ii As Long, St ...

做得不错，学得很快，值得鼓励。

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

[求助] 从网上自动下载更新数据到excel

在上旋下弦月大师的指点下, 按你的要求做了一个, 但没有股票名称.

评分

老大. 你还在想这个呀.

上旋下弦月大师指点了最关键的部分,感谢!

评分

之前代码比较乱. 现修正一下. 请用这版来试.

[求助] 从网上自动下载更新数据到excel

在上旋下弦月大师的指点下, 按你的要求做了一个, 但没有股票名称.

评分

老大. 你还在想这个呀.

上旋下弦月大师 指点了最关键的部分,感谢!

评分

之前代码 比较乱. 现修正一下. 请用这版来试.

上旋下弦月大师指点了最关键的部分,感谢!

之前代码比较乱. 现修正一下. 请用这版来试.