股票交易流水EXCEL表格中的问题-求助(源文件已经添加)
本帖最后由 轩尼狮 于 2020-6-29 17:46 编辑各位大神,最近股票行情不错,跟人合伙凑了点小钱投在股市里面,但是没有合适的记账流水软件,在网上找到一个表格,功能齐全
刚好满足所有的需要,但是现在有一个问题继续帮助,
在持仓汇总页面的持仓明细中,最新价和昨收盘价格不能获取更新,alt＋F11调试错误,但是里面根本就看不懂,再次感谢
这个表格设计的非常合理,但是不知道怎么上传不了.我在最后面,把所有的代码复制上
蓝奏云刚弄好
https://wws.lanzouj.com/ilGKye595qj
百度云
链接：https://pan.baidu.com/s/1B9RMO0Qo_Ac4PO_0Sq6mtA
提取码：15z3
我把提示错误的地方标了蓝色
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
我还以为分享你的电子表格出来呢{:1_927:} 看着 不错 交易软件自己就带流水汇总，而且可以导出为Excel表格。你废这事干啥 一起学习一下。 我觉得钱投股市，还不如去打麻将，还有赢的机会 sadffg 发表于 2020-6-28 10:31
我觉得钱投股市，还不如去打麻将，还有赢的机会
小赌怡情 tulongwa 发表于 2020-6-28 10:03
交易软件自己就带流水汇总，而且可以导出为Excel表格。你废这事干啥
因为牵扯到分账问题,所以要有个交割流水的记录 绿叶红花 发表于 2020-6-28 09:59
我还以为分享你的电子表格出来呢
从excel之家找到的,不是我自己弄的 绿叶红花 发表于 2020-6-28 09:59
我还以为分享你的电子表格出来呢
我是想上传的,但是不知道是权限不够,还是不允许发附件
页:
[1]
2