[已解决][求助]求分类统计代码

zsd5237

附件内I11：K15是用函数求得的分类合计与总计数据，能否用VB代码在D与F列的最后一行数据行下的动态区域进行分类统计。需要说明的是：实际操作时类型数目不确定，数据行也不确定。

jlUY06mf.rar (1.98 KB, 下载次数: 1)

2009-10-30 09:25 上传

点击文件名下载附件
[求助]求分类统计代码

最佳答案

月排行榜 / 总排行榜

amulee

2009-10-30 15:19

pgcY0GK3.rar (9.34 KB, 下载次数: 16)

2009-10-30 15:18 上传

点击文件名下载附件
[求助]求分类统计代码
Sub MySum()
    Dim ArrYS, ArrJG, i&, j%, K&, L&, XLTemp&, d As Object
    ArrYS = Range("D2:S" & Range("D65536").End(xlUp).Row)
    ReDim ArrJG(1 To 16, 0 To 1)
    K = 0
    ArrJG(1, 0) = "合计"
    Set d = CreateObject("SCRIPTING.DICTIONARY")
    For i = 1 To UBound(ArrYS, 1)
        If InStr(1, ArrYS(i, 1), "小计") > 0 Or InStr(1, ArrYS(i, 1), "合计") > 0 Then
            Range("D" & i + 1 & ":F65536").Clear
            Exit For
        End If
        If Not d.exists(ArrYS(i, 1)) Then
            K = K + 1
            d(ArrYS(i, 1)) = K
            ReDim Preserve ArrJG(1 To 16, 0 To K)
            ArrJG(1, K) = ArrYS(i, 1) & "小计"
        End If
        XLTemp = d(ArrYS(i, 1))
        For j = 2 To 16
            If j <> 10 Then
                ArrJG(j, XLTemp) = ArrJG(j, XLTemp) + ArrYS(i, j)
                ArrJG(j, 0) = ArrJG(j, 0) + ArrYS(i, j)
            End If
        Next j
    Next
    Range("D" & Range("D65536").End(xlUp).Row + 1).Resize(UBound(ArrJG, 2) + 1, UBound(ArrJG, 1)) = Application.Transpose(ArrJG)
    Range("D" & i + 1 & ":S" & i + 1).Cut
    Range("D" & Range("D65536").End(xlUp).Row + 1).Insert Shift:=xlDown
End Sub

跳转到最佳答案楼层

FookYou

hB8ASjOS.rar (9.23 KB, 下载次数: 0)

2009-10-30 10:02 上传

点击文件名下载附件
[求助]求分类统计代码
Sub 统计()
  Dim Dic As New Dictionary
  Dim Arr, Sy, dR_n&, i&, k&, N&, N1!, N2!, S$
  Dim Ay() As Single
    dR_n = [d65536].End(xlUp).Row
    If Cells(dR_n, 4) = "合计" Then Exit Sub
    Arr = Range("D2:F" & dR_n)
    For i = 1 To UBound(Arr)
      S = Arr(i, 1) & "小计"
      If Dic.Exists(S) Then
        Sy = Split(Dic(S), "+")
        Sy(0) = Sy(0) + Arr(i, 2)
        Sy(1) = Sy(1) + Arr(i, 3)
        Dic(S) = Join(Sy, "+")
      Else
        Dic.Add Arr(i, 1) & "小计", Arr(i, 2) & "+" & Arr(i, 3)
      End If
    Next i
    k = Dic.Count
    ReDim Ay(1 To k, 1 To 2)
    For i = 1 To k
      Sy = Split(Dic.Items(i - 1), "+")
      Ay(i, 1) = Sy(0)
      Ay(i, 2) = Sy(1)
      N1 = N1 + Sy(0)
      N2 = N2 + Sy(1)
    Next i
    N = dR_n + 1
    Cells(N, 4).Resize(k, 1) = Application.Transpose(Dic.Keys)
    Cells(N, 5).Resize(k, 2) = Ay
    Cells(N + k, 4) = "合计"
    Cells(N + k, 5) = N1
    Cells(N + k, 6) = N2
End Sub

amulee

zUpm5Ecr.rar (9.25 KB, 下载次数: 2)

2009-10-30 10:12 上传

点击文件名下载附件
[求助]求分类统计代码
Sub MySum()
    Dim ArrYS, ArrJG, i&, j%, K&, L&, XLTemp&, d As Object
    ArrYS = Range("D2:F" & Range("D65536").End(xlUp).Row)
    ReDim ArrJG(1 To 3, 0 To 1)
    K = 0
    ArrJG(1, 0) = "合计"
    Set d = CreateObject("SCRIPTING.DICTIONARY")
    For i = 1 To UBound(ArrYS, 1)
        If InStr(1, ArrYS(i, 1), "小计") > 0 Or InStr(1, ArrYS(i, 1), "合计") > 0 Then
            Range("D" & i + 1 & ":F65536").Clear
            Exit For
        End If
        If Not d.exists(ArrYS(i, 1)) Then
            K = K + 1
            d(ArrYS(i, 1)) = K
            ReDim Preserve ArrJG(1 To 3, 0 To K)
            ArrJG(1, K) = ArrYS(i, 1) & "小计"
        End If
        XLTemp = d(ArrYS(i, 1))
        For j = 2 To 3
            ArrJG(j, XLTemp) = ArrJG(j, XLTemp) + ArrYS(i, j)
            ArrJG(j, 0) = ArrJG(j, 0) + ArrYS(i, j)
        Next j
    Next
    Range("D" & Range("D65536").End(xlUp).Row + 1).Resize(UBound(ArrJG, 2) + 1, 3) = Application.Transpose(ArrJG)
    Range("D" & i + 1 & ":F" & i + 1).Cut
    Range("D" & Range("D65536").End(xlUp).Row + 1).Insert Shift:=xlDown
End Sub

zsd5237

2楼老师的代码很好，但如果在数据区内单元格数值有空时会出错（类型不匹配），可是单元数值为0时也是正常好用的。

3楼老师的代码不存在上述问题。

请问二位老师如果分类汇总不止是E与F列时：1、如果要汇总的是E列至S列时，代码如何修改？2、在汇总的E列至S列中，其中M列不需要汇总，则又如何修改？敬请指教！！

amulee

pgcY0GK3.rar (9.34 KB, 下载次数: 16)

2009-10-30 15:18 上传

点击文件名下载附件
[求助]求分类统计代码
Sub MySum()
    Dim ArrYS, ArrJG, i&, j%, K&, L&, XLTemp&, d As Object
    ArrYS = Range("D2:S" & Range("D65536").End(xlUp).Row)
    ReDim ArrJG(1 To 16, 0 To 1)
    K = 0
    ArrJG(1, 0) = "合计"
    Set d = CreateObject("SCRIPTING.DICTIONARY")
    For i = 1 To UBound(ArrYS, 1)
        If InStr(1, ArrYS(i, 1), "小计") > 0 Or InStr(1, ArrYS(i, 1), "合计") > 0 Then
            Range("D" & i + 1 & ":F65536").Clear
            Exit For
        End If
        If Not d.exists(ArrYS(i, 1)) Then
            K = K + 1
            d(ArrYS(i, 1)) = K
            ReDim Preserve ArrJG(1 To 16, 0 To K)
            ArrJG(1, K) = ArrYS(i, 1) & "小计"
        End If
        XLTemp = d(ArrYS(i, 1))
        For j = 2 To 16
            If j <> 10 Then
                ArrJG(j, XLTemp) = ArrJG(j, XLTemp) + ArrYS(i, j)
                ArrJG(j, 0) = ArrJG(j, 0) + ArrYS(i, j)
            End If
        Next j
    Next
    Range("D" & Range("D65536").End(xlUp).Row + 1).Resize(UBound(ArrJG, 2) + 1, UBound(ArrJG, 1)) = Application.Transpose(ArrJG)
    Range("D" & i + 1 & ":S" & i + 1).Cut
    Range("D" & Range("D65536").End(xlUp).Row + 1).Insert Shift:=xlDown
End Sub

FookYou

8aCdmJQm.rar (9.03 KB, 下载次数: 5)

2009-10-30 16:14 上传

点击文件名下载附件
[求助]求分类统计代码
Sub 统计()
  Dim Dic As New Dictionary
  Dim Arr, ArrR, ArrM, Ay, By, dR_n&, mR_n&, i&, j%, k&, S$
  Dim Cy(1 To 1, 1 To 15) As Single
    dR_n = [d65536].End(xlUp).Row
    mR_n = [m65536].End(xlUp).Row
    If Cells(dR_n, 4) = "合计" Then Exit Sub
    Arr = Range("D2:D" & dR_n)
    ArrR = Range("E2:S" & dR_n)
    ArrM = Range("M2:M" & mR_n)
    For i = 1 To UBound(Arr)
      S = Arr(i, 1) & "小计"
      Ay = Application.Index(ArrR, i)
      If Dic.Exists(S) Then
        By = Dic(S)
        For j = 1 To 15
          If j <> 9 Then By(j) = By(j) + Ay(j)
        Next j
        Dic(S) = By
      Else
        Dic.Add S, Ay
      End If
      For j = 1 To 15
        If j <> 9 Then Cy(1, j) = Cy(1, j) + Ay(j)
      Next j
    Next i
    k = Dic.Count
    Cells(dR_n + 1, 4).Resize(k, 1) = Application.Transpose(Dic.Keys)
    For i = 1 To k
      Cells(dR_n + i, 5).Resize(1, 15) = Dic.Items(i - 1)
    Next i
    N = dR_n + 1
    Cells(N + k, 4) = "合计"
    Cells(N + k, 5).Resize(1, 15) = Cy
    Range("M2:M" & mR_n).Value = ArrM
End Sub

zsd5237

6楼老师：谢了。你的代码能做到上述两个要求的分类汇总。但不知你是否注意到还存在一个问题，即：M列数据是不汇总的，因而在各类别的汇总数据行中，对应M列的单元格应该是空白，不能有相应的数据复制，但现在出现在对应各类别汇总数据行中M列单元复制了与各类别对应的第一个数据，这在实际工作中是不应该的，是否代码需要修改一下？对不起，我多嘴了。