ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2345|回复: 2

[求助] Excel股票价格自动更新问题

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-6-28 10:11 | 显示全部楼层 |阅读模式
本帖最后由 轩尼狮 于 2020-6-28 10:15 编辑

非常感谢论坛里面的朋友热心分享

最近跟朋友一起炒股,需要一个流水交割记录表格,在论坛里面找到一个,非常合适,功能齐全,
关于这个表格,多说几句,里面是双账户设计,资金汇总,数据透视,都非常齐全,基本涵盖了股票交割的所有方面,很好的东西,论坛里面有朋友发过的,但是调试错误一直不知道怎么解决

但是在持仓明细部分的价格更新总是提示调试错误,对函数完全不懂,主要是年纪大了,实在没有精力从头开始学

求助高手,帮忙测试,可以免费咨询股票分析

我把那一段的代码都复制了
Option Explicit
Public conn As New ADODB.Connection
Public rst As New ADODB.Recordset
Public strsql As String
Public Const qymc As String = "投资理财管理"
Public Const hysy As String = "_☆★→__龚非"
Sub 年月()
On Error Resume Next
Application.ScreenUpdating = False
Dim arr As Variant
Dim TheList As String
Dim i As Integer
Dim r As Long
r = Sheets("交易流水").Range("a" & Rows.Count).End(xlUp).Row
arr = Sheets("交易流水").Range("a1:d" & r)
    For i = 1 To UBound(arr)
       If Len(arr(i, 1)) <> 0 And InStr(TheList & ",", "," & Year(arr(i, 1)) & "年" & Month(arr(i, 1)) & "月" & ",") = 0 Then TheList = TheList & "," & Year(arr(i, 1)) & "年" & Month(arr(i, 1)) & "月"
    Next i
    With Selection.Validation
      .Delete
      .Add Type:=3, AlertStyle:=1, Operator:=1, Formula1:=Mid(TheList, 2)
      '.ShowError = False
      .InputTitle = qymc & "-系统提示"
      .InputMessage = "选择日期,显示当月持仓"
      .ErrorTitle = qymc & "-系统警告"
      .ErrorMessage = "日期不能输入!只能选择"
    End With
Application.ScreenUpdating = True
Exit Sub
End Sub
Sub 持仓更新()
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim i, j, m, n As Integer
Dim ny, nn, yy
Dim r, r1, l, l1 As Long
Dim xrg As Range, xaddress
Dim URL, Temp, arr, dm, df
r = Sheets("交易流水").Range("a" & Rows.Count).End(xlUp).Row
l = Sheets("交易流水").Cells(1, Columns.Count).End(xlToLeft).Column
r1 = Range("b" & Rows.Count).End(xlUp).Row
l1 = Cells(2, Columns.Count).End(xlToLeft).Column

If r1 > 10 Then Range(Cells(11, 2), Cells(r1, 5)).ClearContents
Set xrg = Sheets("交易流水").Range("a1").Resize(r, l)
  xaddress = xrg.Address(0, 0)
Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName
  strsql = "select distinct 账户,代码,名称 from [交易流水$" & xaddress & "] where 代码 is not null order by 账户,代码"
    rst.Open strsql, conn, adOpenKeyset, adLockOptimistic
      n = rst.RecordCount
      m = rst.Fields.Count
   If n = 0 Then GoTo 1
   ReDim arr(1 To n, 1 To m + 2)
       For i = 1 To n
         For j = 1 To m
          arr(i, j) = rst.Fields(j - 1)
         Next j
       rst.MoveNext
     Next i
  Temp = CreateObject("Wscript.shell").Run("ping qt.gtimg.cn -n 1", 0, True)
  If Temp <> 0 Then
    MsgBox "没有更新最新价,请检查网络是否通畅!", , qymc & "-系统提示"
    Range("b11").CopyFromRecordset rst
   Else
   For i = 1 To n
     dm = arr(i, 2)
     If Left(Val(dm), 2) = 60 Then
            URL = "http://qt.gtimg.cn/q=sh" & dm
        Else
            URL = "http://qt.gtimg.cn/q=sz" & dm
     End If
     With CreateObject("msxml2.xmlhttp")
        .Open "GET", URL, False
        .send
        df = Split(.responsetext, "~")
     End With
     If df(3) = 0 Then
     arr(i, 4) = df(4)
     arr(i, 5) = df(4)
     Else
     arr(i, 4) = df(3)
     arr(i, 5) = df(4)
     End If
    Next i
    Range("b11").Resize(n, 5) = arr
   ' Range("c11:c" & 11 + n).NumberFormatLocal = "'" & "@"
  End If
    With ActiveSheet.PageSetup
       .TopMargin = 6
       .LeftMargin = 3
       .RightMargin = 3
       .HeaderMargin = 3
       .FooterMargin = 3
       .Orientation = 2 'xlLandscape
       .CenterHorizontally = True
       .CenterVertically = False
       .PrintArea = Range(Cells(1, 2), Cells(n + 10, l1)).Address
       .Zoom = Sheets("基础资料").Range("a7").Value
    End With
1:
conn.Close
Set rst = Nothing
Set conn = Nothing
0:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
End Sub





批注 2020-06-28 093446.png

蓝色部分提示错误

蓝色部分提示错误

最新价和收盘价不能自动更新

最新价和收盘价不能自动更新

券商对照.rar

67.47 KB, 下载次数: 111

TA的精华主题

TA的得分主题

发表于 2020-6-28 17:22 | 显示全部楼层
你这张表应该可以用Power BI来实现更新。

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-6-28 17:42 | 显示全部楼层
papshaw 发表于 2020-6-28 17:22
你这张表应该可以用Power BI来实现更新。

大哥,完全不懂什么是Power BI

我能把股票部分的搞明白,但是持仓明细不能更新抓取价格,就跟让我教非洲人用电脑打猎差不多一个意思
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-6 10:01 , Processed in 0.031784 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表