[已解决]VBA余额计算提高运算速度问题

龙送农

VBA余额计算问题（为提高运算速度，先判断已经计算的就不用计算，从未计算的单元格起往下计算余额）

最佳答案

月排行榜 / 总排行榜

grf1973

2015-1-5 15:23

把你的代码用数组改了一遍

1. Sub 余额计算()
   
2.     arr = [a1].CurrentRegion
   
3.     For x = 6 To UBound(arr)
   
4.         Select Case arr(x, 6)
   
5.             Case "本月合计"
   
6.               arr(x, 8) = x1
   
7.               arr(x, 10) = x2
   
8.               arr(x, 9) = x3
   
9.               arr(x, 11) = x4
   
10.               arr(x, 13) = arr(x - 1, 13)
    
11.               x1 = 0: x2 = 0: x3 = 0: x4 = 0
    
12.             Case "本年累计"
    
13.               arr(x, 8) = y1
    
14.               arr(x, 10) = y2
    
15.               arr(x, 9) = y3
    
16.               arr(x, 11) = y4
    
17.               arr(x, 13) = arr(x - 1, 13)
    
18.             Case Else
    
19.                 x1 = x1 + arr(x, 8)
    
20.                 x2 = x2 + arr(x, 10)
    
21.                 x3 = x3 + arr(x, 9)
    
22.                 x4 = x4 + arr(x, 11)
    
23.                 y1 = y1 + arr(x, 8)
    
24.                 y2 = y2 + arr(x, 10)
    
25.                 y3 = y3 + arr(x, 9)
    
26.                 y4 = y4 + arr(x, 11)
    
27.                 arr(x, 13) = arr(x - 1, 13) + arr(x, 8) - arr(x, 10)
    
28.             End Select
    
29.             If arr(x, 13) > 0 Then
    
30.                 arr(x, 12) = "借"
    
31.             ElseIf arr(x, 13) = 0 Then
    
32.                 arr(x, 12) = "平"
    
33.             ElseIf arr(x, 13) < 0 Then
    
34.                 arr(x, 12) = "贷"
    
35.             End If
    
36.             arr(x, 13) = Round(arr(x, 13), 2)         '余额保留两位小数
    
37.      Next x
    
38.      [a1].CurrentRegion = arr
    
39. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 计算余额()
   
2.     arr = Range("a1:m" & [a65536].End(3).Row)
   
3.     r = [m65536].End(3).Row
   
4.     For i = r + 1 To UBound(arr)
   
5.         If arr(i, 6) <> "" Then
   
6.             arr(i, 13) = arr(i - 1, 13)
   
7.         Else
   
8.             arr(i, 13) = arr(i - 1, 13) + arr(i, 8) - arr(i, 10)
   
9.         End If
   
10.     Next
    
11.     [m1].Resize(UBound(arr), 1) = Application.Index(arr, , 13)
    
12. End Sub

复制代码

grf1973

已将M列285行以下全部清空（原表中有公式）

龙送农

grf1973 发表于 2015-1-5 14:00
已将M列285行以下全部清空（原表中有公式）

还有H、I、J、K列没有进行“本月合计”“本年累计”，L列“借”可“贷”显示。我的想法是：先判断M列余额已经计算到的非空单元格，然后从空单元格开始运行表里已有的代码。

wp8680

其实一开始你的方法选择就错了，利用事件，或者放在内存数组中进行运算，所得结果一次性写入单元格，就会快很多的。

grf1973

把你程序的头小改一下：
Sub 余额计算()
'Range("L6:M10000").ClearContents '清除余额信息
Dim Temp1 As Integer
Dim x As Integer
r = [m65536].End(3).Row
Temp1 = Range("a4").CurrentRegion.Rows.Count
For x = r To Temp1

grf1973

这样也不对的，你要算本月合计，本年累计，本就要从第一条记录开始累加的

龙送农

wp8680 发表于 2015-1-5 14:25
其实一开始你的方法选择就错了，利用事件，或者放在内存数组中进行运算，所得结果一次性写入单元格，就会快 ...

老师，麻烦您帮我重新写一个。

grf1973

把你的代码用数组改了一遍

1. Sub 余额计算()
   
2.     arr = [a1].CurrentRegion
   
3.     For x = 6 To UBound(arr)
   
4.         Select Case arr(x, 6)
   
5.             Case "本月合计"
   
6.               arr(x, 8) = x1
   
7.               arr(x, 10) = x2
   
8.               arr(x, 9) = x3
   
9.               arr(x, 11) = x4
   
10.               arr(x, 13) = arr(x - 1, 13)
    
11.               x1 = 0: x2 = 0: x3 = 0: x4 = 0
    
12.             Case "本年累计"
    
13.               arr(x, 8) = y1
    
14.               arr(x, 10) = y2
    
15.               arr(x, 9) = y3
    
16.               arr(x, 11) = y4
    
17.               arr(x, 13) = arr(x - 1, 13)
    
18.             Case Else
    
19.                 x1 = x1 + arr(x, 8)
    
20.                 x2 = x2 + arr(x, 10)
    
21.                 x3 = x3 + arr(x, 9)
    
22.                 x4 = x4 + arr(x, 11)
    
23.                 y1 = y1 + arr(x, 8)
    
24.                 y2 = y2 + arr(x, 10)
    
25.                 y3 = y3 + arr(x, 9)
    
26.                 y4 = y4 + arr(x, 11)
    
27.                 arr(x, 13) = arr(x - 1, 13) + arr(x, 8) - arr(x, 10)
    
28.             End Select
    
29.             If arr(x, 13) > 0 Then
    
30.                 arr(x, 12) = "借"
    
31.             ElseIf arr(x, 13) = 0 Then
    
32.                 arr(x, 12) = "平"
    
33.             ElseIf arr(x, 13) < 0 Then
    
34.                 arr(x, 12) = "贷"
    
35.             End If
    
36.             arr(x, 13) = Round(arr(x, 13), 2)         '余额保留两位小数
    
37.      Next x
    
38.      [a1].CurrentRegion = arr
    
39. End Sub

复制代码

龙送农

grf1973 发表于 2015-1-5 15:23
把你的代码用数组改了一遍

虽然您没有按我所述的完成，但您改的代码确实快多了，我达到了我要的效果