[已解决]使用vba完成数据分类汇总，并抽取数据

davidkang85

由于基础的成交汇总查询报表太多，手工生成汇总日报表特别麻烦。希望能够写一个vba程序，在界面上增加一个按钮，不必打开其他excel，手工点击该按钮更新汇总日报报表的内容。希望将所有的买入、卖出成交金额汇总填写到汇总日报表对应的行，然后将分红信息单独复制到下面


求各个大神帮忙。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-11-8 14:47

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, MySht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set MySht = ActiveSheet
   
7.     MySht.Rows("11:65536").ClearContents
   
8.     Do While Filename <> ""
   
9.         If Filename <> ThisWorkbook.Name Then
   
10.             fn = ThisWorkbook.Path & "" & Filename
    
11.             Set wb = Workbooks.Open(fn)
    
12.             Set Sht = wb.Worksheets(1)
    
13.             arr = Sht.[a1].CurrentRegion
    
14.             For i = 2 To UBound(arr)
    
15.                 x = arr(i, 2) & arr(i, 4)   '产品名称+业务类别为key
    
16.                 If arr(i, 4) = "买入" Or arr(i, 4) = "卖出" Then
    
17.                     d(x) = d(x) + arr(i, 8) '成交金额累加为item
    
18.                 ElseIf arr(i, 4) = "分红" Then
    
19.                     r = r + 1
    
20.                     Sht.Rows(i).Copy MySht.Rows(r + 10)         '复制“分红”行
    
21.                 End If
    
22.             Next
    
23.             wb.Close False
    
24.         End If
    
25.         Filename = Dir
    
26.     Loop
    
27.     With MySht      '显示结果
    
28.         arr = .[a3:e5]
    
29.         For i = 2 To UBound(arr)
    
30.             For j = 2 To UBound(arr, 2)
    
31.                 x = arr(1, j) & Left(arr(i, 1), 2)      '产品名称+业务类别为key
    
32.                 arr(i, j) = d(x)
    
33.             Next
    
34.         Next
    
35.         .[a3:e5] = arr
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

跳转到最佳答案楼层

su45

下载次数不少，但没人回复，估计就是问题没说清楚，还是先自己检查下附件吧！

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, MySht As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set MySht = ActiveSheet
   
7.     MySht.Rows("11:65536").ClearContents
   
8.     Do While Filename <> ""
   
9.         If Filename <> ThisWorkbook.Name Then
   
10.             fn = ThisWorkbook.Path & "" & Filename
    
11.             Set wb = Workbooks.Open(fn)
    
12.             Set Sht = wb.Worksheets(1)
    
13.             arr = Sht.[a1].CurrentRegion
    
14.             For i = 2 To UBound(arr)
    
15.                 x = arr(i, 2) & arr(i, 4)   '产品名称+业务类别为key
    
16.                 If arr(i, 4) = "买入" Or arr(i, 4) = "卖出" Then
    
17.                     d(x) = d(x) + arr(i, 8) '成交金额累加为item
    
18.                 ElseIf arr(i, 4) = "分红" Then
    
19.                     r = r + 1
    
20.                     Sht.Rows(i).Copy MySht.Rows(r + 10)         '复制“分红”行
    
21.                 End If
    
22.             Next
    
23.             wb.Close False
    
24.         End If
    
25.         Filename = Dir
    
26.     Loop
    
27.     With MySht      '显示结果
    
28.         arr = .[a3:e5]
    
29.         For i = 2 To UBound(arr)
    
30.             For j = 2 To UBound(arr, 2)
    
31.                 x = arr(1, j) & Left(arr(i, 1), 2)      '产品名称+业务类别为key
    
32.                 arr(i, j) = d(x)
    
33.             Next
    
34.         Next
    
35.         .[a3:e5] = arr
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38. End Sub

复制代码

davidkang85

grf1973 发表于 2016-11-8 14:47

应该是这段代码有问题，计算出来的金额翻倍了

•    If arr(i, 4) = "买入" Or arr(i, 4) = "卖出" Then
•                     d(x) = d(x) + arr(i, 8) '成交金额累加为item
  

davidkang85

grf1973 发表于 2016-11-8 14:47

又看了一下，是我的数据有问题，您给出的答案是正确的，非常感谢。