Excel股票价格自动更新问题

轩尼狮

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

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

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

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

我把那一段的代码都复制了
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

papshaw

你这张表应该可以用Power BI来实现更新。

轩尼狮

papshaw 发表于 2020-6-28 17:22
你这张表应该可以用Power BI来实现更新。

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

我能把股票部分的搞明白,但是持仓明细不能更新抓取价格,就跟让我教非洲人用电脑打猎差不多一个意思