Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2410|回复: 5

[已解决]在aa列有小计,有分项,根据小计所在行计算小计行下的分项行数据

[复制链接]
发表于 2013-1-20 19:37 | 显示全部楼层 |阅读模式
在aa列有小计,有分项,根据小计所在行计算小计行下的分项行数据的和
计算从d列开始到w列结束
Book1.rar (23.81 KB, 下载次数: 36)
 楼主| 发表于 2013-1-20 20:53 | 显示全部楼层
Sub xiaoji()
     Dim hang As Integer, i As Integer
     hang = Range("b65536").End(xlUp).Row
     With Range("aa8:aa" & hang)
     Set c = .Find("小计", LookIn:=xlValues)
     If Not c Is Nothing Then
         firstAddress = c.Address
         Do
             MsgBox "当前单元格是:" & c.Address(0, 0)
             Set c = .FindNext(c)
         Loop While Not c Is Nothing And c.Address <> firstAddress
     End If
End With
End Sub
回复

使用道具 举报

 楼主| 发表于 2013-1-21 12:02 | 显示全部楼层
请优化代码
Sub xiaoji()
    Dim hang As Integer, c As Range, j As Integer, arr(1 To 100), ct As Integer, ctmax As Integer
    hang = Range("b65536").End(xlUp).Row
    With Range("aa8:aa" & hang)
    Set c = .Find("小计", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Row
        ct = 1
        arr(ct) = c.Row
        ct = ct + 1
        Set c = .FindNext(c)
        Do
        arr(ct) = c.Row
        ct = ct + 1
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress And c.Row <> arr(1)
    End If
    ctmax = ct - 2
    ct = 1
    For ct = 1 To ctmax
    ctt = ct + 1
    For j = 4 To 23
            Cells(arr(ct), j) = WorksheetFunction.SumIf(Range(Cells(arr(ct), "aa"), Cells(arr(ctt), "aa")), "分项", Range(Cells(arr(ct), j), Cells(arr(ctt), j)))
        Next j
    Next ct
    ct = ctmax + 1
    For j = 4 To 23
            Cells(arr(ct), j) = WorksheetFunction.SumIf(Range(Cells(arr(ct), "aa"), Cells(655365, "aa")), "分项", Range(Cells(arr(ct), j), Cells(655365, j)))
        Next j
End With
End Sub
回复

使用道具 举报

发表于 2013-1-22 13:13 | 显示全部楼层    本楼为最佳答案   
  1. Sub Xiaoji2()
  2. '---------------------------------------------------------------------------------------
  3. ' Procedure : Xiaoji2
  4. ' Author    : hwc2ycy
  5. ' Date      : 2013/1/22
  6. ' Purpose   :通过数组的方式累加,并写入数组,没有关闭刷屏,如果数据量大,需要关闭刷屏。
  7. '---------------------------------------------------------------------------------------
  8. '
  9.     Dim arr, arr2, RowCur&, j&
  10.     Dim iRow&, result(1 To 1, 1 To 20)
  11.     iRow = Range("b65536").End(xlUp).Row
  12.     arr = Range("aa1:aa" & iRow)
  13.     arr2 = Range("d1:w" & iRow)
  14.     For i = 1 To UBound(arr)
  15.         If arr(i, 1) = "小计" Then
  16.             RowCur = i
  17.             Debug.Print i & "行"
  18.             Erase result
  19.             i = i + 1
  20.             If i > iRow Then Exit For
  21.             Do
  22.                 If arr(i, 1) = "分项" Then
  23.                     For j = LBound(arr2, 2) To UBound(arr2, 2)
  24.                         result(1, j) = result(1, j) + arr2(i, j)
  25.                     Next
  26.                 End If
  27.                 i = i + 1
  28.                 If i > iRow Then Exit Do
  29.             Loop Until arr(i, 1) = "小计"
  30.             i = i - 1
  31.             Cells(RowCur, "d").Resize(, UBound(result, 2)) = result
  32.         End If
  33.     Next
  34.     MsgBox "统计完成!", vbInformation + vbOKOnly, "恭喜"
  35. End Sub
复制代码
回复

使用道具 举报

发表于 2013-1-22 13:13 | 显示全部楼层

如何贴代码.gif

评分

参与人数 1 +3 收起 理由
hcy1185 + 3 神马都是浮云

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-1-23 08:54 | 显示全部楼层
用字典写了一个如下
Sub 由分项计算小计()
Dim hang As Integer, fc As Range, firstAddress As Integer '此变量为String时使用删除最后关键字语句
Dim dic As Object, ct As Integer, arr As Variant
Dim i As Integer, j As Integer
Set dic = CreateObject("scripting.dictionary") '后期绑定
hang = Range("b65536").End(xlUp).Row
With Range("aa8:aa" & hang)
    Set fc = .Find("小计", LookIn:=xlValues)
    If Not fc Is Nothing Then
        firstAddress = fc.Row
        dic(firstAddress) = ""
        Do
        Set fc = .FindNext(fc)
            ct = fc.Row
            dic(ct) = ""
        Loop While Not fc Is Nothing And fc.Row <> firstAddress
        'If dic.Count = 0 Then Exit Sub '此3行删除字典最后关键字
            'arr = dic.keys
            'dic.Remove arr(dic.Count - 1)
            dic(hang) = ""
    End If
    arr = dic.keys
    For i = LBound(arr) To UBound(arr) - 1
    For j = 4 To 23
        Cells(arr(i), j) = WorksheetFunction.SumIf(Range(Cells(arr(i), "aa"), Cells(arr(i + 1), "aa")), _
        "分项", Range(Cells(arr(i), j), Cells(arr(i + 1), j)))
        Cells(arr(i), j).Font.ColorIndex = 4: Cells(arr(i), j).Font.FontStyle = "加粗"
    Next j
    Next i
End With
Set dic = Nothing '释放字典
End Sub
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 23:33 , Processed in 0.463159 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表