[已解决]自动统计累计占比数据并写入汇总表问题

sdwffw

Book1.zip (4.05 KB, 下载次数: 27)

2014-6-19 16:22 上传

点击文件名下载附件

问题见附件表一，请老师指导，感谢!

最佳答案

月排行榜 / 总排行榜

dsmch

2014-6-19 17:50

………………

跳转到最佳答案楼层

sdwffw

Book2.zip (4.2 KB, 下载次数: 24)

2014-6-19 16:56 上传

点击文件名下载附件 以“青州”表为例，做了一个效果示例，其它两个表没做，请老师参考。

江河行地

=VLOOKUP($B2,INDIRECT(E$1&"!B2:C30"),2,)
下拉 右拉

sdwffw

江河行地 发表于 2014-6-19 17:03
=VLOOKUP($B2,青州!B$2:C$30,2,)
=VLOOKUP($B2,诸城!B2:C30,2,)
=VLOOKUP($B2,寿光!B$2:C$30,2,)

想法是VBA编码解决提出的所有问题，同时，我的表可能还要增加若干个单位。老师的解答只是用函数解决了汇总表数据调入的问题，其它分表中的问题也没解决。谢谢老师

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, j%, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheets("汇总表").Range("a1").CurrentRegion
   
5. ReDim brr(1 To UBound(arr) - 1, 1 To Sheets.Count - 1)
   
6. For j = 1 To Sheets.Count
   
7.     If Sheets(j).Name <> "汇总表" Then
   
8.         Sheets(j).Activate
   
9.         sht = Sheets(j).Name
   
10.         ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
    
11.         n = Range("a65536").End(xlUp).Row - 1
    
12.         [f1] = Application.Sum(Range("c2").Resize(n, 1))
    
13.         [d2] = "=C2/$F$1"
    
14.         With Range("d2").Resize(n, 1)
    
15.             .NumberFormatLocal = "0.0%"
    
16.             .FillDown
    
17.             .Value = .Value
    
18.         End With
    
19.         [a1].Resize(n + 1, 4).Sort [d2], Order1:=xlDescending, Header:=xlGuess
    
20.         h = 0
    
21.         For i = 2 To n
    
22.             zf = Cells(i, 1) & sht
    
23.             h = h + Cells(i, 4)
    
24.             If h < 0.75 And h > 0 Then d(zf) = Cells(i, 3) Else [a2].Resize(i - 1, 4).Interior.ColorIndex = 3: Exit For
    
25.         Next
    
26.     End If
    
27.     [f1] = ""
    
28. Next
    
29. For i = 2 To UBound(arr)
    
30.     For j = 3 To UBound(arr, 2)
    
31.         zf = arr(i, 1) & arr(1, j)
    
32.         brr(i - 1, j - 2) = d(zf)
    
33.     Next
    
34. Next
    
35. Sheets("汇总表").Activate
    
36. [c2].Resize(UBound(brr), UBound(brr, 2)) = brr
    
37. End Sub
    

复制代码

dsmch

………………

sdwffw

dsmch 发表于 2014-6-19 17:50
………………

非常感谢老师，问题完美解决！！不过，我改了改工作簿表名和表中的第一行内容，程序出错不能运行，不知何因，再麻烦老师看看。 复件 Book1.zip (10.89 KB, 下载次数: 7)

2014-6-19 20:38 上传

点击文件名下载附件

sdwffw

dsmch老师，因我还需按后面出问题的表格样式再统计数据，所以自己尝试修改了表名和第一行字段名称，但是出错了，提示：[f1] = Application.Sum(Range("c2").Resize(n, 1))代码有问题，因我VBA刚开始学，自己也没查明原因。第 一种表格样式非常完美！

dsmch

Sub Macro1()
Dim arr, brr, d, i&, j%, n&
Set d = CreateObject("scripting.dictionary")
arr = Sheets("汇总表").Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To Sheets.Count - 1)
For j = 1 To Sheets.Count
    If Sheets(j).Name <> "汇总表" Then
        Sheets(j).Activate
        sht = Sheets(j).Name
        ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
        n = Range("b65536").End(xlUp).Row - 1
        [f1] = Application.Sum(Range("c2").Resize(n, 1))
        [d2] = "=C2/$F$1"
        With Range("d2").Resize(n, 1)
            .NumberFormatLocal = "0.0%"
            .FillDown
            .Value = .Value
        End With
        [a1].Resize(n + 1, 4).Sort [d2], Order1:=xlDescending, Header:=xlGuess
        h = 0
        For i = 2 To n
            zf = Cells(i, 2) & sht
            h = h + Cells(i, 4)
            If h < 0.75 And h > 0 Then d(zf) = Cells(i, 3) Else [a2].Resize(i - 1, 4).Interior.ColorIndex = 3: Exit For
        Next
    End If
    [f1] = ""
Next
For i = 2 To UBound(arr)
    For j = 3 To UBound(arr, 2)
        zf = arr(i, 2) & arr(1, j)
        brr(i - 1, j - 2) = d(zf)
    Next
Next
Sheets("汇总表").Activate
[c2].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

sdwffw

dsmch 发表于 2014-6-19 22:07
Sub Macro1()
Dim arr, brr, d, i&, j%, n&
Set d = CreateObject("scripting.dictionary")

明白了，原来是第一列未填数据的原因，谢谢老师。