急！求VBA数组 字典优化程序（附件运行需40多分钟，还不及Sumif）

2841889887

多行多列求合：“数据源表“上第6列为组合判断条件，“目标表“上第28列至48列为组合判断条件，不知道如何利用程序组合这些判断条件；目前该表上的简单VBA程序运行时间多达40多分钟，急死人了！苦于不会VBA编程，还请老师帮助解决，谢谢了！！！

山菊花

Sub 物料用途整理()
    Dim nR1%, nL1%, nR2&, nR%, nL%, nJe, Arr(), Brr()
    Dim ds As Object
    Set ds = CreateObject("Scripting.Dictionary") '创建字典
    With Sheets("目标表")
        nR1 = .Range("b4").End(xlDown).Row
        nL1 = .Range("b4").End(xlToRight).Column
        .Range(.Range("d6"), .Cells(nR1, nL1)).ClearContents
        Arr = .Range(.Range("b4"), .Cells(nR1, nL1)).Value
    End With
    With Sheets("数据源表")
        nR2 = .Range("a3").End(xlDown).Row
        Brr = .Range("b4:e" & nR2).Value
    End With
    For i = 4 To nL1 - 1
        ds(Arr(2, i)) = i
    Next
    For i = 4 To nR1 - 3
        ds(Arr(i, 1) & Arr(i, 2)) = i
    Next
    For i = 1 To nR2 - 3
        nJe = Brr(i, 4)
        nL = ds(Left(Brr(i, 3), 4))
        nR = ds(Brr(i, 1) & Brr(i, 2))
        If nL * nR * nJe <> 0 Then
            Arr(3, 3) = Arr(3, 3) + nJe
            Arr(3, nL) = Arr(3, nL) + nJe
            Arr(nR, nL) = Arr(nR, nL) + nJe
            Arr(nR, 3) = Arr(nR, 3) + nJe
            nR = ds(Brr(i, 1) & "合计")
            If nR > 0 Then
                Arr(nR, nL) = Arr(nR, nL) + nJe
                Arr(nR, 3) = Arr(nR, 3) + nJe
            End If
        End If
    Next
    With Sheets("目标表")
        .Range(.Range("b4"), .Cells(nR1, nL1)).Value = Arr
    End With
End Sub

2841889887

谢谢山菊花老师！！！

excel002009

代码：

1. Sub 目标表()
   
2. Dim rg As Range, arr, brr, crr, drr, i As Long, j As Long
   
3. Application.ScreenUpdating = False
   
4. With Sheets("目标表")
   
5. .Range("aa4").Resize(1, 21).ClearContents
   
6.     arr = .Range("e4:y4").Value
   
7.     brr = .Range("e5:y5").Value
   
8.     crr = .Range("b7:b704").Value
   
9.     drr = .Range("c7:c704").Value
   
10.     For Each rg In .Range("aa4").Resize(1, 21)
    
11.         i = i + 1
    
12.         rg.Value = arr(1, i)
    
13.     Next
    
14.     m = .Range("y" & .Rows.Count).End(xlUp).Row - 1
    
15.     .Range("aa7:au" & m).ClearContents
    
16.     j = 1: i = 0
    
17.     For Each rg In .Range("aa7:au" & m)
    
18.         If i = 21 Then
    
19.           i = 0
    
20.           j = j + 1
    
21.         End If
    
22.         i = i + 1
    
23.         If drr(j, 1) <> "合计" Then
    
24.            rg.Value = brr(1, i) & crr(j, 1) & drr(j, 1)
    
25.         End If
    
26.     Next
    
27. End With
    
28. Application.ScreenUpdating = True
    
29. End Sub
    
30. 
    
31. Sub 数据源表()
    
32. Dim arr, brr(), i As Long, j As Long
    
33. Application.ScreenUpdating = False
    
34. With Sheets("数据源表")
    
35.       arr = .Range("b4:d10000")
    
36.       ReDim brr(1 To UBound(arr), 1 To 1)
    
37.       For i = 1 To UBound(arr)
    
38.           brr(i, 1) = Left(arr(i, 3), 4) & arr(i, 1) & arr(i, 2)
    
39.       Next
    
40.       .Range("f4:f10000").ClearContents
    
41.       .Range("f4:f10000").Value = brr
    
42. End With
    
43. Application.ScreenUpdating = True
    
44. End Sub

复制代码

附件：
求助VBA数组字典优化程序.zip (455.98 KB, 下载次数: 23)

2014-8-25 20:25 上传

点击文件名下载附件

2841889887

完全达到目的，太好了，现运行速度很快，再次谢谢！！！
山菊花老师能出面解决问题，我真是太幸运了,之前多次看到山菊花老师，此次增强努力学习VBA的信心。
对该程序还不了解，还要一点一点学习，逐步理解。

2841889887

谢谢4楼老师出手相救！！！

2841889887

如果在数据源表上即在“金额”前插入三列，代码又如何修改，还请老师对代码解释一下，谢谢！！！

2841889887

自问自答：

如果在数据源表上“金额”列前增加插入三列，则需修改代码如下：
Sub 物料用途整理()
    Dim nR1%, nL1%, nR2&, nR%, nL%, nJe, arr(), brr()
    Dim ds As Object
    Set ds = CreateObject("Scripting.Dictionary") '创建字典
    With Sheets("目标表")
        nR1 = .Range("b4").End(xlDown).Row
        nL1 = .Range("b4").End(xlToRight).Column
        .Range(.Range("d6"), .Cells(nR1, nL1)).ClearContents
        arr = .Range(.Range("b4"), .Cells(nR1, nL1)).Value
    End With
    With Sheets("数据源表")
        nR2 = .Range("a3").End(xlDown).Row
        brr = .Range("b4:h" & nR2).Value
    End With
    For i = 4 To nL1 - 1
        ds(arr(2, i)) = i
    Next
    For i = 4 To nR1 - 3
        ds(arr(i, 1) & arr(i, 2)) = i
    Next
    For i = 1 To nR2 - 3
        nJe = brr(i, 7)
        nL = ds(Left(brr(i, 3), 4))
        nR = ds(brr(i, 1) & brr(i, 2))
        If nL * nR * nJe <> 0 Then
            arr(3, 3) = arr(3, 3) + nJe
            arr(3, nL) = arr(3, nL) + nJe
            arr(nR, nL) = arr(nR, nL) + nJe
            arr(nR, 3) = arr(nR, 3) + nJe
            nR = ds(brr(i, 1) & "合计")
            If nR > 0 Then
                arr(nR, nL) = arr(nR, nL) + nJe
                arr(nR, 3) = arr(nR, 3) + nJe
            End If
        End If
    Next
    With Sheets("目标表")
        .Range(.Range("b4"), .Cells(nR1, nL1)).Value = arr
    End With
End Sub

2841889887

若在“目标表”上C列、D列之间增加九列后，再在“合计”所在和物料1所在列之间增加一列，代码如何修改？请老师帮助解决，谢谢！

cqcbc

适合于多条件汇总的例子，速度快。