[已解决]请帮忙编一个股票高管持股变动的自定义数据的VBA代码

另类2011

现有一组股市中的高管持股变动情况的数据：

代码	日期	变动股数		代码	日期
601890	2014-12-5	-10.00万		SH601890	2014-12-5	-100000
300334	2014-12-4	-1.00万		SZ300334	2014-12-4	-360000
300334	2014-12-4	-35.00万		SZ300334	2014-12-4	-360000
777	2014-12-4	-4791		SZ000777	2014-12-4	-4791
300094	2014-12-4	-5000		SZ300094	2014-12-4	-5000
2404	2014-12-4	-1.00万		SZ002404	2014-12-4	-10000
2576	2014-12-4	-6000		SZ002576	2014-12-4	-56000
2576	2014-12-4	-5.00万		SZ002576	2014-12-4	-56000
2304	2014-12-4	-69.92万		SZ002304	2014-12-4	-699200
300264	2014-12-4	-700万		SZ300264	2014-12-4	-7000000
300075	2014-12-4	-150万		SZ300075	2014-12-4	-1500000
600322	2014-12-3	-1.00万		SH600322	2014-12-3	-15000
600322	2014-12-3	-5000		SH600322	2014-12-3	-15000
2488	2014-12-3	-1.00万		SZ002488	2014-12-3	-10000
300226	2014-12-3	-3000		SZ300226	2014-12-3	-3000
2107	2014-12-3	-4.00万		SZ002107	2014-12-3	-40000

前面的是原始数据，后面的是完成后的数值，这里要求的是：
1，把带“万”的数据变成正常的数值，
2，把同一日期，并且同一代码的数值求和，比如第三、第四行的300334求和后的数值是360000，
3，把“6”字头的代码前面加上“SH”，其它代码恢复成六位数后前面再加"SZ"，比如第五行的777变成了SZ000777，
这样的数据就可以编成自定义数据，导入大智慧软件调用了，由于天天都要更新，原来都是手工操作的感觉很繁琐，所以只有请老师们帮忙了，谢谢！！！！！！！！！

最佳答案

月排行榜 / 总排行榜

xdragon

2014-12-7 14:44

1. Sub 自定义格式()
   
2.      Dim arr, re, d As Object, i&, dkey$
   
3.      arr = Range("A3:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.      Set d = CreateObject("scripting.dictionary")
   
5.      For i = 1 To UBound(arr)
   
6.          dkey = IIf(Left(arr(i, 1), 1) = "6", "SH", "SZ") & Format(arr(i, 1), "000000") & "|" & arr(i, 2)
   
7.          d(dkey) = d(dkey) + IIf(InStr(arr(i, 3), "万"), Replace(arr(i, 3), "万", "") * 10000, arr(i, 3))
   
8.      Next
   
9.      arr = d.keys
   
10.      ReDim re(1 To d.Count, 1 To 3)
    
11.      For i = 0 To UBound(arr)
    
12.          re(i + 1, 1) = Split(arr(i), "|")(0)
    
13.          re(i + 1, 2) = Split(arr(i), "|")(1)
    
14.          re(i + 1, 3) = d(arr(i))
    
15.      Next
    
16.      Range("E3").Resize(UBound(re), UBound(re, 2)) = re
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

xdragon

1. Sub 自定义格式()
   
2.      Dim arr, re, d As Object, i&, dkey$
   
3.      arr = Range("A3:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.      Set d = CreateObject("scripting.dictionary")
   
5.      For i = 1 To UBound(arr)
   
6.          dkey = IIf(Left(arr(i, 1), 1) = "6", "SH", "SZ") & Format(arr(i, 1), "000000") & "|" & arr(i, 2)
   
7.          d(dkey) = d(dkey) + IIf(InStr(arr(i, 3), "万"), Replace(arr(i, 3), "万", "") * 10000, arr(i, 3))
   
8.      Next
   
9.      arr = d.keys
   
10.      ReDim re(1 To d.Count, 1 To 3)
    
11.      For i = 0 To UBound(arr)
    
12.          re(i + 1, 1) = Split(arr(i), "|")(0)
    
13.          re(i + 1, 2) = Split(arr(i), "|")(1)
    
14.          re(i + 1, 3) = d(arr(i))
    
15.      Next
    
16.      Range("E3").Resize(UBound(re), UBound(re, 2)) = re
    
17. End Sub
    

复制代码

另类2011

xdragon 发表于 2014-12-7 14:44

谢谢xdragon 老师！辛苦了！好人一生平安！！！！！！！

另类2011

xdragon 发表于 2014-12-7 14:44

看代码里好像没有限制具体行数，测试了变天到2399行时还可以，可是到2499行时就出问题了，不知道是什么原因，请老师有空看看，麻烦了！多谢！！！！！！

另类2011

xdragon 发表于 2014-12-7 14:44

不好意思，查到问题了，在2440行上有个数据是1.35亿，麻烦老师在下面代码上加一个“亿”的换算，拜托！谢谢！！！！！！
d(dkey) = d(dkey) + IIf(InStr(arr(i, 3), "万"), Replace(arr(i, 3), "万", "") * 10000, arr(i, 3))

xdragon

1. Sub 自定义格式()
   
2.      Dim arr, re, d As Object, i&, dkey$
   
3.      arr = Range("A3:C" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
4.      Set d = CreateObject("scripting.dictionary")
   
5.      For i = 1 To UBound(arr)
   
6.          dkey = IIf(Left(arr(i, 1), 1) = "6", "SH", "SZ") & Format(arr(i, 1), "000000") & "|" & arr(i, 2)
   
7.          d(dkey) = d(dkey) + GetPrice(arr(i, 3))
   
8.      Next
   
9.      arr = d.keys
   
10.      ReDim re(1 To d.Count, 1 To 3)
    
11.      For i = 0 To UBound(arr)
    
12.          re(i + 1, 1) = Split(arr(i), "|")(0)
    
13.          re(i + 1, 2) = Split(arr(i), "|")(1)
    
14.          re(i + 1, 3) = d(arr(i))
    
15.      Next
    
16.      Range("E3").Resize(UBound(re), UBound(re, 2)) = re
    
17. End Sub
    
18. 
    
19. Function GetPrice#(NumString)
    
20.      Select Case Right(NumString, 1)
    
21.          Case "亿"
    
22.              GetPrice = Replace(NumString, "亿", "") * 100000000
    
23.          Case "万"
    
24.              GetPrice = Replace(NumString, "万", "") * 10000
    
25.          Case Else
    
26.              GetPrice = Val(NumString)
    
27.      End Select
    
28. End Function

复制代码

另类2011

xdragon 发表于 2014-12-7 17:24

ok了！谢谢xdragon老师！辛苦了！！！！！！！！！！！！！！！！！