[已解决]运行慢，求助公式改代码

文轩馨婷

总要求：根据“汇总表”公式改代码

汇总表注意事项：1.产品编号不重复，2.每月数据相对应，3.排序列不好设代码可删除（此列作用用于排列产品编号中间的数字：如产品编号：18420-011-00202，提取是011，产品编号没有中间数字就不需要提取）



在此恭候老师们的解答！


在此先谢过！！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-5-21 18:25

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 16), d, i%, j&, s&
Set d = CreateObject("scripting.dictionary")
For i = 1 To Sheets.Count - 1
    arr = Sheets(i).Range("a1").CurrentRegion
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            s = s + 1
            d(arr(j, 1)) = s
            brr(s, 1) = arr(j, 1)
            brr(s, 2) = arr(j, 2)
            brr(s, 3) = arr(j, 3)
            brr(s, i + 3) = arr(j, 4)
        Else
            brr(d(arr(j, 1)), i + 3) = arr(j, 4)
        End If
    Next
Next
Sheets("汇总表").Activate
Range("a2:p60000").ClearContents
Range("a2").Resize(s, 16) = brr
[p2] = "=SUM(D2:O2)"
With [p2].Resize(s)
    .FillDown
    .Value = .Value
End With
End Sub

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr(1 To 60000, 1 To 16), d, i%, j&, s&
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 4 To Sheets.Count - 1
   
6.     arr = Sheets(i).Range("a1").CurrentRegion
   
7.     For j = 2 To UBound(arr)
   
8.         If Not d.exists(arr(j, 1)) Then
   
9.             s = s + 1
   
10.             d(arr(j, 1)) = s
    
11.             brr(s, 1) = arr(j, 1)
    
12.             brr(s, 2) = arr(j, 2)
    
13.             brr(s, 3) = arr(j, 3)
    
14.             brr(s, i) = arr(j, 4)
    
15.         Else
    
16.             brr(d(arr(j, 1)), i) = arr(j, 4)
    
17.         End If
    
18.     Next
    
19. Next
    
20. Sheets("汇总表").Activate
    
21. Range("a2:p60000").ClearContents
    
22. Range("a2").Resize(s, 16) = brr
    
23. [p2] = "=SUM(D2:O2)"
    
24. With [p2].Resize(s)
    
25.     .FillDown
    
26.     .Value = .Value
    
27. End With
    
28. End Sub
    

复制代码

dsmch

附件中公式已全部删除，否则代码受其影响运行很慢

文轩馨婷

dsmch 发表于 2014-5-21 17:02
附件中公式已全部删除，否则代码受其影响运行很慢

老师，
  如果删除之前隐藏的“1月份”2月份“3月份”这三个表——代码会怎样变化？

文轩馨婷

dsmch 发表于 2014-5-21 17:02
附件中公式已全部删除，否则代码受其影响运行很慢

老师
    我试了，受影响！——如附件截图

文轩馨婷

dsmch 发表于 2014-5-21 17:02
附件中公式已全部删除，否则代码受其影响运行很慢

老师：
  这样我也改过，还是不行！

dsmch

Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 16), d, i%, j&, s&
Set d = CreateObject("scripting.dictionary")
For i = 1 To Sheets.Count - 1
    arr = Sheets(i).Range("a1").CurrentRegion
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 1)) Then
            s = s + 1
            d(arr(j, 1)) = s
            brr(s, 1) = arr(j, 1)
            brr(s, 2) = arr(j, 2)
            brr(s, 3) = arr(j, 3)
            brr(s, i + 3) = arr(j, 4)
        Else
            brr(d(arr(j, 1)), i + 3) = arr(j, 4)
        End If
    Next
Next
Sheets("汇总表").Activate
Range("a2:p60000").ClearContents
Range("a2").Resize(s, 16) = brr
[p2] = "=SUM(D2:O2)"
With [p2].Resize(s)
    .FillDown
    .Value = .Value
End With
End Sub

文轩馨婷

dsmch 发表于 2014-5-21 18:25
Sub Macro1()
On Error Resume Next
Dim arr, brr(1 To 60000, 1 To 16), d, i%, j&, s&

谢谢！

可以拉！{:25:}