[已解决]VBA单条件求和

安全网

求助VBA单条件对数据进行求次数和金额的求和，统计后的数据如公司名称从小到大排列

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-15 20:02

1. Sub TJ()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     arr = Range("A2").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 1)
   
7.         If arr(i, 5) * arr(i, 6) > 0 Then
   
8.             d(x) = d(x) + 1
   
9.             d1(x) = d1(x) + arr(i, 5)
   
10.         End If
    
11.     Next
    
12.     With Sheet2
    
13.         .Cells.Clear
    
14.         .[a2].Resize(1, 4) = Array("序号", "公司", "授信次数", "授信额度")
    
15.         .[b3].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d.items, d1.items))
    
16.         .[b3].Resize(d.Count, 3).Sort key1:=.[b3]  '按公司名称排序
    
17.         For i = 1 To d.Count: .Cells(i + 2, 1) = i: Next
    
18.         .Cells(i + 2, 2) = "汇总"
    
19.         .Cells(i + 2, 3).Resize(, 2).Formula = "=sum(r3c:r[-1]c)"
    
20.         .Activate
    
21.     End With
    
22.     MsgBox "统计完成！"
    
23. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub TJ()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     arr = Range("A2").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 1)
   
7.         d(x) = d(x) + 1
   
8.         d1(x) = d1(x) + arr(i, 5)
   
9.     Next
   
10.     With Sheet2
    
11.         .Cells.Clear
    
12.         .[a2].Resize(1, 4) = Array("序号", "公司", "授信次数", "授信额度")
    
13.         .[b3].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d.items, d1.items))
    
14.         .[b3].Resize(d.Count, 3).Sort key1:=.[b3]  '按公司名称排序
    
15.         For i = 1 To d.Count: .Cells(i + 2, 1) = i: Next
    
16.         .Activate
    
17.     End With
    
18.     MsgBox "统计完成！"
    
19. End Sub
    

复制代码

安全网

grf1973 发表于 2015-12-15 15:09

Sub TJ()
    Application.ScreenUpdating = False
    Dim WB As Workbook
    Set WB = Workbooks.Open(Filename:="E:\数据表\数据总表.xls", Password:="123", WriteResPassword:="123")
    y = WB.Sheets(1).Range("D" & Rows.Count).End(xlUp).Row
    arr = WB.Sheets(1).Range("A3:AM" & y)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = WB.Sheets(1).Range("A2").CurrentRegion
    For i = 2 To UBound(arr)
        x = arr(i, 14)
        d(x) = d(x) + 1
        d1(x) = d1(x) + arr(i, 13)
    Next
        WB.Close True
    Set WB = Nothing

    With ThisWorkbook
    With Sheet11
        .Cells.Clear
        .[a2].Resize(1, 4) = Array("序号", "公司", "授信次数", "授信额度")
        .[b3].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d.items, d1.items))
        .[b3].Resize(d.Count, 3).Sort key1:=.[b3]  '按公司名称排序
        For i = 1 To d.Count: .Cells(i + 2, 1) = i: Next
        .Activate
    End With
    End With
    Application.ScreenUpdating = True
    MsgBox "统计完成！"
End Sub

安全网

帮忙 看看这个代码错误在哪里

grf1973

上面arr已经用四至范围定义了，下面再用arr=....currentregion就没有必要了。

grf1973

With ThisWorkbook
    With Sheet11

写成
With ThisWorkbook.Sheet11
比较好一点

grf1973

至于文件打开，数组定义是否出错是要看附件调试才知道的。

安全网

grf1973 发表于 2015-12-15 16:37
至于文件打开，数组定义是否出错是要看附件调试才知道的。

现在碰到授信额度内空或者担保额度内空，就不计数和金额，怎么设置，后面的值内要加个汇总栏怎么设置

grf1973

1. Sub TJ()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary")
   
4.     arr = Range("A2").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         x = arr(i, 1)
   
7.         If arr(i, 5) * arr(i, 6) > 0 Then
   
8.             d(x) = d(x) + 1
   
9.             d1(x) = d1(x) + arr(i, 5)
   
10.         End If
    
11.     Next
    
12.     With Sheet2
    
13.         .Cells.Clear
    
14.         .[a2].Resize(1, 4) = Array("序号", "公司", "授信次数", "授信额度")
    
15.         .[b3].Resize(d.Count, 3) = Application.Transpose(Array(d.keys, d.items, d1.items))
    
16.         .[b3].Resize(d.Count, 3).Sort key1:=.[b3]  '按公司名称排序
    
17.         For i = 1 To d.Count: .Cells(i + 2, 1) = i: Next
    
18.         .Cells(i + 2, 2) = "汇总"
    
19.         .Cells(i + 2, 3).Resize(, 2).Formula = "=sum(r3c:r[-1]c)"
    
20.         .Activate
    
21.     End With
    
22.     MsgBox "统计完成！"
    
23. End Sub

复制代码

安全网

grf1973 发表于 2015-12-15 20:02

像图片的错误是什么原因引起的，怎么样修改VBA可以避免