如何给VBA提速？一个程序运行时间超过一小时。。

天blue

我是vba 银行间金融债rating_bond.zip (60.47 KB, 下载次数: 19)

2013-4-11 16:37 上传

点击文件名下载附件

新手，在帮公司做一个数据。源数据是很多只债券的评级信息，如AAA(长期信用评级-中诚信国际信用评级有限责任公司-20020919)/AAA(长期信用评级-中诚信国际信用评级有限责任公司-20110905)
/AAA(长期信用评级-中诚信国际信用评级有限责任公司-20120905)
/AAA(长期信用评级-中诚信国际信用评级有限责任公司-20121221)，现在希望把评级信息和债券做成二维表，行标签是债券，列是从债券上市以来的时间，将评级填充进去。我编了一个程序，但是运行太慢了，尤其是一个excel中的债券数量达到上千、时间序列好多年之后更慢。
附上我编的程序，希望高手指导一下，小女子感激不尽！

522971384

ps：其实超算还是有用武之地的哈{:soso_e113:}，我不是大牛，解决不了你的问题，帮顶一个！

天blue

有没有人知道，求帮忙啊！

hehex

天blue 发表于 2013-4-17 13:19
有没有人知道，求帮忙啊！

你最好提供一段原数据的片段，和要的结果。而不是你现在附件里的那一段难解的代码。
拿了你的附件还要猜你的需求，恐怕没办法给你写。

grf1973

1. Sub 评级()
   
2. 
   
3.     Rows("4:65536").ClearContents
   
4.    
   
5.     '挑选出所有有评级的股票，放在第4、5行
   
6.     arr = Range([a1], Cells(2, [a1].End(xlToRight).Column))
   
7.     k = 1
   
8.     For i = 1 To UBound(arr, 2)
   
9.         If arr(2, i) <> "" Then
   
10.         Cells(4, k) = arr(1, i): Cells(5, k) = arr(2, i)
    
11.         k = k + 1
    
12.         End If
    
13.     Next
    
14.     Erase arr
    
15.    
    
16. ' 把所有评级分解后按日期填入，相同日期填在同一行
    
17. Set d = CreateObject("scripting.dictionary")
    
18. arr = Range([b5], Cells(5, [b5].End(xlToRight).Column))
    
19. For i = 1 To UBound(arr, 2)
    
20.     brr = Split(arr(1, i), "/")
    
21.     For j = 0 To UBound(brr)
    
22.         r = Cells(65536, 1).End(3).Row + 1
    
23.         riqi = GetNum(brr(j))     '函数GetNum:把一个字符串中的数字全部筛选出来
    
24.         'pinji = Replace(brr(j), "-" & riqi, "")   '显示评级的全部内容
    
25.         pinji = Split(brr(j), "(")(0)              '仅显示评级的级别（AAA、AA+等）
    
26.         If d.exists(riqi) = False Then
    
27.             d(riqi) = ""
    
28.         Else
    
29.             r = Range("A1:A" & r).Find(riqi).Row
    
30.         End If
    
31.          Cells(r, 1) = riqi: Cells(r, i + 1) = pinji
    
32.     Next
    
33. Next
    
34. 
    
35. '把填好后的评级按日期进行排序
    
36.   Set myrng = Range([a6], Cells([a6].End(xlDown).Row, [a4].End(xlToRight).Column))
    
37.   myrng.Sort Key1:=Range("A2:A" & [a6].End(xlDown).Row), Order1:=xlAscending
    
38.   Rows(5).Delete    '删除辅助行
    
39. 
    
40. End Sub
    
41. 
    
42. Function GetNum(str)   '把一个字符串中的数字全部筛选出来
    
43. With CreateObject("VBSCRIPT.REGEXP")  '正则表达式
    
44.     .Global = True
    
45.     .Pattern = "[^0-9.]"     '数字模式
    
46.     GetNum = .Replace(str, "")
    
47. End With
    
48. End Function
    

复制代码

请看附件，简化了一下，只把有评级内容的股票筛选了出来。

Evanish

我试着写了个，还是这个表的话3分钟可以运行完，代码运行完之后你把评级的AAA手工替换成数字吧，这段代码你也只可以自己加。
我也是新手，有啥问题大家一起探讨，一起提高。