[已解决]求助老师帮助呀VBA

excel白兔

Sub 汇总()
    Dim arr1, arr2(), ARR3()
    Dim D, Row1, i, J, M, S2, S3
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("原料及主要材料（物料准确表）")
        Row1 = .Range("D65536").End(xlUp).Row
        arr1 = .Range("D2:F" & Row1)
        For i = 1 To UBound(arr1)
            If arr1(i, 1) <> 0 Then
                    S2 = S2 + arr1(i, 2)
                    S3 = S3 + arr1(i, 3)
                    If Not D.exists(arr1(i, 1)) Then
                   M = M + 1
                    D(arr1(i, 1)) = M
                    ReDim Preserve arr2(1 To 3, 1 To M)
                    arr2(1, M) = arr1(i, 1)
                    arr2(2, M) = arr1(i, 2)
                    arr2(3, M) = arr1(i, 3)
                Else
                    arr2(2, D(arr1(i, 1))) = arr2(2, D(arr1(i, 1))) + arr1(i, 2)
                    arr2(3, D(arr1(i, 1))) = arr2(3, D(arr1(i, 1))) + arr1(i, 3)
                End If
            Else
                GoTo 100
            End If
           ' Stop
        Next i
    End With
100:
    ReDim ARR3(1 To M + 1, 1 To 3)
    For i = 1 To M
        For J = 1 To 3
            If J = 1 Then
                 ARR3(i, J) = arr2(J, i) & "汇总"
                 Else
                 ARR3(i, J) = arr2(J, i)
                 End If
        Next J
    Next i
    ARR3(M + 1, 1) = "总计"
    ARR3(M + 1, 2) = S2
    ARR3(M + 1, 3) = S3
    Range("D2:F65536").ClearContents
    Range("D2").Resize(UBound(ARR3), 3) = ARR3
End Sub

蓝色的代码意思 有点多  是在不好意思我很想知道这个代码的意思 我懂了才会更改运用

最佳答案

月排行榜 / 总排行榜

雄鹰

2012-3-23 10:06

Sub 汇总()
    Dim arr1, arr2(), ARR3()
    Dim D, Row1, i, J, M, S2, S3
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("原料及主要材料（物料准确表）")
        Row1 = .Range("D65536").End(xlUp).Row
        arr1 = .Range("D2:F" & Row1)
        For i = 1 To UBound(arr1)
            If arr1(i, 1) <> 0 Then
                    S2 = S2 + arr1(i, 2)
                    S3 = S3 + arr1(i, 3)
                    If Not D.exists(arr1(i, 1)) Then
                   M = M + 1                          'm加1
                    D(arr1(i, 1)) = M                 '再将m的值赋给arr1(i,1)
                    ReDim Preserve arr2(1 To 3, 1 To M) '重新定义数组arr2的数量
                    arr2(1, M) = arr1(i, 1)    '将数组arr1的第i组第一个的量传递给arr2的第1个的第m个
                    arr2(2, M) = arr1(i, 2)
                    arr2(3, M) = arr1(i, 3)
                Else   '否则
                    arr2(2, D(arr1(i, 1))) = arr2(2, D(arr1(i, 1))) + arr1(i, 2)   '将arr2的第2组第D(arr1(i, 1))个的值 加上 arr1数组的第i组的第2个后 传递给arr2(2, D(arr1(i, 1)))
                    arr2(3, D(arr1(i, 1))) = arr2(3, D(arr1(i, 1))) + arr1(i, 3)
                End If
            Else
                GoTo 100   '转到标签100处（红色处）
            End If
           ' Stop
        Next i
    End With
100:
    ReDim ARR3(1 To M + 1, 1 To 3)   '重新定义数组arr3的下标
    For i = 1 To M
        For J = 1 To 3
            If J = 1 Then
                 ARR3(i, J) = arr2(J, i) & "汇总"    '对arr3的第i组第j个值进行变化
                 Else   '否则
                 ARR3(i, J) = arr2(J, i)   '对对arr3的第i组第j个值进行变化
                 End If
        Next J
    Next i
    ARR3(M + 1, 1) = "总计"
    ARR3(M + 1, 2) = S2
    ARR3(M + 1, 3) = S3
    Range("D2:F65536").ClearContents    '清除指定区域的公式。清除图表中的数据但保留格式设置。
    Range("D2").Resize(UBound(ARR3), 3) = ARR3    '调整指定区域的大小。
End Sub

在代码框里，对不明白的代码选中变蓝后，再按F1键会弹出帮助对话框，可以帮助你了解代码的含义。

跳转到最佳答案楼层

雄鹰

Sub 汇总()
    Dim arr1, arr2(), ARR3()
    Dim D, Row1, i, J, M, S2, S3
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("原料及主要材料（物料准确表）")
        Row1 = .Range("D65536").End(xlUp).Row
        arr1 = .Range("D2:F" & Row1)
        For i = 1 To UBound(arr1)
            If arr1(i, 1) <> 0 Then
                    S2 = S2 + arr1(i, 2)
                    S3 = S3 + arr1(i, 3)
                    If Not D.exists(arr1(i, 1)) Then
                   M = M + 1                          'm加1
                    D(arr1(i, 1)) = M                 '再将m的值赋给arr1(i,1)
                    ReDim Preserve arr2(1 To 3, 1 To M) '重新定义数组arr2的数量
                    arr2(1, M) = arr1(i, 1)    '将数组arr1的第i组第一个的量传递给arr2的第1个的第m个
                    arr2(2, M) = arr1(i, 2)
                    arr2(3, M) = arr1(i, 3)
                Else   '否则
                    arr2(2, D(arr1(i, 1))) = arr2(2, D(arr1(i, 1))) + arr1(i, 2)   '将arr2的第2组第D(arr1(i, 1))个的值 加上 arr1数组的第i组的第2个后 传递给arr2(2, D(arr1(i, 1)))
                    arr2(3, D(arr1(i, 1))) = arr2(3, D(arr1(i, 1))) + arr1(i, 3)
                End If
            Else
                GoTo 100   '转到标签100处（红色处）
            End If
           ' Stop
        Next i
    End With
100:
    ReDim ARR3(1 To M + 1, 1 To 3)   '重新定义数组arr3的下标
    For i = 1 To M
        For J = 1 To 3
            If J = 1 Then
                 ARR3(i, J) = arr2(J, i) & "汇总"    '对arr3的第i组第j个值进行变化
                 Else   '否则
                 ARR3(i, J) = arr2(J, i)   '对对arr3的第i组第j个值进行变化
                 End If
        Next J
    Next i
    ARR3(M + 1, 1) = "总计"
    ARR3(M + 1, 2) = S2
    ARR3(M + 1, 3) = S3
    Range("D2:F65536").ClearContents    '清除指定区域的公式。清除图表中的数据但保留格式设置。
    Range("D2").Resize(UBound(ARR3), 3) = ARR3    '调整指定区域的大小。
End Sub

在代码框里，对不明白的代码选中变蓝后，再按F1键会弹出帮助对话框，可以帮助你了解代码的含义。