【2014VBA初级班】课前练习1——分类汇总

王谦

Sub Training_Q()
Dim endrow
Dim arow
Dim Month_d
Dim Year_d
Dim amonth
Dim ayear
Application.ScreenUpdating = False
endrow = Range("a1").End(xlDown).Row
Set Month_d = CreateObject("scripting.dictionary")
Set Year_d = CreateObject("scripting.dictionary")

For arow = 2 To endrow
    amonth = Month(Cells(arow, 1).Value)
    ayear = Year(Cells(arow, 1).Value)
    Month_d(ayear & amonth) = Month_d(ayear & amonth) + Cells(arow, 5).Value
    Year_d(ayear) = Year_d(ayear) + Cells(arow, 5).Value
    If Month(Cells(arow, 1).Value) <> Month(Cells(arow + 1, 1).Value) Then
       Rows(arow + 1 & ":" & arow + 2).Insert Shift:=xlDown
      
       Cells(arow + 1, 1).Value = Cells(arow, 1).Value
       Cells(arow + 2, 1).Value = Cells(arow, 1).Value
      
       Cells(arow + 1, 4).Value = "本期合计"
       Cells(arow + 2, 4).Value = "本年合计"
      
       Cells(arow + 1, 5).Value = Month_d(ayear & amonth)
       Cells(arow + 2, 5).Value = Year_d(ayear)
      
       arow = arow + 2
       endrow = endrow + 2
    End If
Next
Application.ScreenUpdating = True
MsgBox "操作完了", , "通知"
      
End Sub
http://www.excelpx.com/forum.php?mod=attachment&aid=MzE2OTYxfGYxNzM3MWQzMjBhOWE5YzJiZjJiZjdmZGQ1ZjcxYWZlfDE3MTcyODMxMTc%3D&request=yes&_f=.zip

不信这样还重名

答案详见附件，有劳学委批阅下了{:071:}
练习1-分类汇总.zip (67.35 KB, 下载次数: 2)

2014-3-31 18:04 上传

点击文件名下载附件

Sub Macro3()
Dim arr, x, y, k, tempY, tempM, arr月(1 To 10000, 6), arr年(1 To 10000, 6), Sum月, Sum年, arr列(1 To 10000)
Application.ScreenUpdating = False
If ThisWorkbook.Sheets("数据源").AutoFilterMode <> True Then Range("A1:F1").AutoFilter '先确定数据按日期升序排列
ActiveWorkbook.Worksheets("数据源").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("数据源").Sort
        .SetRange Range("a2:f" & Range("a65536").End(xlUp).Row + 1)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
arr = Range("a2:f" & Range("a65536").End(xlUp).Row + 1) '录入数据，多给一行
tempY = Year(arr(1, 1)) '给定初始值
tempM = Month(arr(1, 1))
Sum月 = arr(1, 5)
Sum年 = arr(1, 5)
    For x = 2 To UBound(arr) '处理数据，从第二个开始比较
        If Month(arr(x, 1)) = tempM Then '如果是同期的，那么把金额累加
            Sum月 = Sum月 + arr(x, 5)
            Sum年 = Sum年 + arr(x, 5)
        Else '如果不是同期的，则总结一次
            k = k + 1
            arr列(k) = x + 1 '记录下行号
            arr月(k, 1) = arr(x - 1, 1) '记录日期
            arr月(k, 4) = "本期合计"
            arr月(k, 5) = Sum月 '结算同期金额
            tempM = Month(arr(x, 1)) '重置当前月
            Sum月 = arr(x, 5) '重置同期总计
            
                arr年(k, 1) = arr(x - 1, 1)
                arr年(k, 4) = "本年合计"
                arr年(k, 5) = Sum年
            If Year(arr(x, 1)) = tempY Then '如果还是同一年的，继续累加
                Sum年 = Sum年 + arr(x, 5)
            Else '若不是，则结算年总计，重置年总计
                Sum年 = arr(x, 5): tempY = Year(arr(x, 1))
            End If
        End If
'       If x = 390 Then Stop
    Next x
    For y = k To 1 Step -1 '输出数据
        Rows(arr列(y) & ":" & arr列(y) + 1).Insert Shift:=xlDown
        Range("a" & arr列(y)).Offset(0) = arr月(y, 1)
        Range("a" & arr列(y)).Offset(1) = arr年(y, 1)
        Range("a" & arr列(y)).Offset(0, 3) = arr月(y, 4)
        Range("a" & arr列(y)).Offset(1, 3) = arr年(y, 4)
        Range("a" & arr列(y)).Offset(0, 4) = arr月(y, 5)
        Range("a" & arr列(y)).Offset(1, 4) = arr年(y, 5)
    Next y
Application.ScreenUpdating = True
End Sub

车仁静

1. select 记账日期,凭证类型,凭证编号,摘要,借方,贷方 from [数据源$A:F]
   
2. union all
   
3. select max(记账日期),"","","本期合计",sum(借方),sum(贷方) FROM [数据源$A:F] group by year(记账日期),month(记账日期)
   
4. union all
   
5. select max(记账日期),"","","本年合计",dsum("借方","[数据源$A:F]","year(记账日期)='"&year(记账日期)&"' and month(记账日期)<="&month(记账日期)&""),dsum("贷方","[数据源$A:F]","year(记账日期)='"&year(记账日期)&"' and month(记账日期)<="&month(记账日期)&"") from [数据源$A:F] group by year(记账日期),month(记账日期)  
   
6. order by 记账日期,摘要 desc

复制代码

lasharks

代码放在模块1内，解法比较丑陋。

1. Sub lasharks1()
   
2. Application.ScreenUpdating = False
   
3. Dim i As Integer, arr, brr, y As Integer, m As Integer, j As Integer, k As Integer
   
4. Dim temp_m1 As Double, temp_m2 As Double, temp_y1 As Double, temp_y2 As Double
   
5. With Sheet9
   
6. arr = .Range("a1:f" & .Range("a65536").End(xlUp).Row)
   
7. ReDim brr(1 To 10000, 1 To UBound(arr, 2))
   
8. For k = 1 To UBound(arr, 2)
   
9.          brr(1, k) = arr(1, k)
   
10. Next
    
11. For i = 2 To UBound(arr)
    
12. If y = 0 Then y = Year(arr(i, 1)): m = Month(arr(i, 1)): j = i
    
13. If Year(arr(i, 1)) = y Then
    
14.    If Month(arr(i, 1)) = m Then
    
15.       temp_m1 = temp_m1 + arr(i, 5)
    
16.       temp_m2 = temp_m2 + arr(i, 6)
    
17.         For k = 1 To UBound(arr, 2)
    
18.          brr(j, k) = arr(i, k)
    
19.         Next
    
20.         j = j + 1
    
21.     Else
    
22.       temp_y1 = temp_y1 + temp_m1
    
23.       temp_y2 = temp_y2 + temp_m2
    
24.       brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本期合计": brr(j, 5) = temp_m1: brr(j, 6) = temp_m2
    
25.       j = j + 1
    
26.       temp_m1 = arr(i, 5)
    
27.       temp_m2 = arr(i, 6)
    
28.       brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本年合计": brr(j, 5) = temp_y1: brr(j, 6) = temp_y2
    
29.       j = j + 1
    
30.       For k = 1 To UBound(arr, 2)
    
31.          brr(j, k) = arr(i, k)
    
32.       Next
    
33.       j = j + 1
    
34.       m = Month(arr(i, 1))
    
35.     End If
    
36. Else
    
37.     y = Year(arr(i, 1)): m = Month(arr(i, 1))
    
38.     brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本期合计": brr(j, 5) = temp_m1: brr(j, 6) = temp_m2
    
39.     j = j + 1
    
40.     brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本年合计": brr(j, 5) = temp_y1 + temp_m1: brr(j, 6) = temp_y2 + temp_m2
    
41.     j = j + 1
    
42.     For k = 1 To UBound(arr, 2)
    
43.          brr(j, k) = arr(i, k)
    
44.     Next
    
45.     j = j + 1
    
46.     temp_m1 = arr(i, 5)
    
47.     temp_m2 = arr(i, 6)
    
48.     temp_y1 = 0
    
49.     temp_y2 = 0
    
50. End If
    
51. Next
    
52.     brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本期合计": brr(j, 5) = temp_m1: brr(j, 6) = temp_m2
    
53.     j = j + 1
    
54.     brr(j, 1) = arr(i - 1, 1): brr(j, 4) = "本年合计": brr(j, 5) = temp_y1 + temp_m1: brr(j, 6) = temp_y2 + temp_m2
    
55.    
    
56.    .Columns("Q:V").Clear
    
57.    .Range("A1:F1").Select
    
58.     Selection.Copy
    
59.     .Range("Q1:V1").Select
    
60.     Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    
61.     Application.CutCopyMode = False
    
62.     .Range("A2:F2").Select
    
63.     Selection.Copy
    
64.     .Range("q2").Resize(j - 1, UBound(arr, 2)).Select
    
65.     Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    
66.     Application.CutCopyMode = False
    
67. .Range("q1").Resize(j, UBound(arr, 2)) = brr
    
68. End With
    
69. Application.ScreenUpdating = True
    
70. End Sub

复制代码

开心妙妙

1. Sub 分类汇总()
   
2.     Dim i%, i1%, i2%, i3%, i4%, t
   
3.     t = Timer
   
4.     Dim sm As Double
   
5.     Dim sy As Double
   
6.     Application.ScreenUpdating = False  '禁止刷新屏幕
   
7.     For i = 2 To Range("A65536").End(xlUp).Row + 6 * 12 * 2
   
8.         '行循环，最大行号取:每月插入二行空行共08-13共6年*12个月*2行+最大非空行号
   
9.         sm = Cells(i, 5) + sm  '合计本期数据变量
   
10.         If Left(Cells(i, 1), 7) <> Left(Cells(i + 1, 1), 7) Then    '如果截取前面7个文本当前行<>下一行文本,即月份不相同的
    
11.             Rows(i + 1).Insert    '在当前行+1插入行
    
12.             Rows(i + 1).Insert    '在当前行+1插入行
    
13.             Cells(i + 1, 1) = Cells(i, 1)    '当前行即月末行赋值给下一行,下一行即本期合计行
    
14.             Cells(i + 2, 1) = Cells(i, 1)    '当前行即月末行赋值给下一行,下下一行即本年合计行
    
15.             Cells(i + 1, 4) = "本期合计"
    
16.             Cells(i + 2, 4) = "本年合计"
    
17.             Cells(i + 1, 5) = sm    '本期合计数据赋值到第五列的当前行的下一行
    
18.             sy = sy + sm  '将本期合计数据赋值给本年合计变量
    
19.             Cells(i + 2, 5) = sy  '本年合计赋值给当前行下下一行
    
20.             Range("A" & i + 1 & ":F" & i + 1).Interior.ColorIndex = 34  '本期合计行填充颜色
    
21.             Range("A" & i + 2 & ":F" & i + 2).Interior.ColorIndex = 33    '本年合计行填充颜色
    
22.             If Left(Cells(i, 1), 4) <> Left(Cells(i + 3, 1), 4) Then
    
23.                 '如果截取前面4个文本<>当前行+3的文本,+3是因为月末都插入了二个,所以要和下三行的年份比较
    
24.                 sy = 0  '本年合计数又从0开始
    
25.             End If
    
26.             sm = 0    '本期合计赋值后又从0开始
    
27.             i = i + 2    '循环值+2,因月末插入了二行
    
28.         End If
    
29.     Next i
    
30.     Application.ScreenUpdating = True    '刷新屏幕
    
31.     MsgBox Timer - t
    
32. End Sub
    

复制代码

风林火山

1. Sub 汇总() '风林
   
2.     Dim arr, brr(), k%, n%, i%, m%, d, dArray, dn%, isum1 As Double, isum2 As Double, t As Single
   
3.     t = Timer '初始时间
   
4.     arr = Range("a1:f" & Cells(Rows.Count, 1).End(3).Row).Value '定义数据源
   
5.     Set d = CreateObject("scripting.dictionary") '创建字典实例
   
6.     For k = 2 To UBound(arr) '字典添加关键字，已日期的前7位作为关键字
   
7.         d(Left(arr(k, 1), 7)) = ""
   
8.     Next k
   
9.     dArray = d.keys '字典数据转数组，方便提取
   
10.     ReDim Preserve brr(1 To UBound(arr) + d.Count * 2 + 1, 1 To UBound(arr, 2)) '重新定义目标数组，原数组行数+字典个数*2+1
    
11.    
    
12.     For dn = 0 To UBound(dArray) - 1 '关键字循环
    
13.     For k = 2 + m To UBound(arr) '提取数据
    
14.         If Left(arr(k, 1), 7) = dArray(dn) Then '判断是否等于关键字
    
15.             n = n + 1 '确定数据在目标数组中的位置
    
16.             For i = 1 To UBound(arr, 2) '循环赋值
    
17.                 brr(n, i) = arr(k, i) '赋值
    
18.             Next i '下一个
    
19.             isum1 = isum1 + arr(k, 5) '累加本月合计
    
20.             isum2 = isum2 + arr(k, 5) '累加本年合计
    
21.         Else
    
22.             brr(n + 1, 4) = "本月合计": brr(n + 1, 5) = isum1 '生成本月合计，并填充数据
    
23.             brr(n + 2, 4) = "本年合计": brr(n + 2, 5) = isum2 '生成本年合计，并填充数据
    
24.             n = n + 2: isum1 = 0 '数组位置更新，同时清空本月合计
    
25.             Exit For '退出循环
    
26.         End If
    
27.         m = m + 1 '已使用过的区域的行数统计，便于下次统计时，不会重复统计
    
28.     Next k
    
29.     Next dn
    
30.     Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr '在目标区域显示数据
    
31.     MsgBox "用时" & Timer - t & "秒" '计算运算时间
    
32. End Sub

复制代码

开心妙妙

用数组循环方法：

1. Sub 分类汇总开心妙妙()
   
2.     Dim i%, i1%, c%
   
3.     Dim sm As Double, sy As Double, t As Single
   
4.     Dim Arr, Arr1
   
5.     t = Timer
   
6.     Application.ScreenUpdating = False
   
7.     Arr = Range("A1:E" & Range("A65536").End(xlUp).Row + 1)
   
8.     '区域装入数组,+1行是循环时减一行,避免与下一行比较时没有下一行可以比较造成下标越界
   
9.     Range("A2:F" & Range("A65536").End(xlUp).Row).ClearContents '清除数据源
   
10.     ReDim Arr1(1 To UBound(Arr) + 6 * 12 * 2, 1 To 5)  '定义新的字典
    
11.     For i = 2 To UBound(Arr) - 1  '数据源数组循环
    
12.         i1 = i1 + 1  '计算目标数据的行数
    
13.         sm = sm + Arr(i, 5)  '本期合计
    
14.         For c = 1 To 5  '列循环
    
15.             Arr1(i1, c) = Arr(i, c)  '按列装入新数组
    
16.         Next c
    
17.         If Left(Arr(i, 1), 7) <> Left(Arr(i + 1, 1), 7) Then  '
    
18.             Arr1(i1 + 1, 1) = Arr(i, 1)
    
19.             Arr1(i1 + 2, 1) = Arr(i, 1)
    
20.             Arr1(i1 + 1, 4) = "本期合计"
    
21.             Arr1(i1 + 2, 4) = "本年合计"
    
22.             Arr1(i1 + 1, 5) = sm
    
23.             sy = sy + sm
    
24.             Arr1(i1 + 2, 5) = sy
    
25.             If Left(Arr(i, 1), 4) <> Left(Arr(i + 1, 1), 4) Then
    
26.                 sy = 0
    
27.             End If
    
28.             sm = 0
    
29.             i1 = i1 + 2
    
30.         End If
    
31.     Next i
    
32.     Application.ScreenUpdating = True
    
33.     Range("A2").Resize(i1, 5) = Arr1
    
34.     MsgBox Timer - t
    
35. End Sub

复制代码