谁帮我写段有关统计汇总的代码

hxl000

求助：谁帮我写段有关统计汇总的代码

FLY-VITAS

1. Sub 分类统计()
   
2.     Dim rng As Range, arr
   
3.     Set rng = ActiveSheet.UsedRange
   
4.     arr = rng.Value
   
5.    Application.DisplayAlerts = False
   
6.     On Error Resume Next
   
7.         With CreateObject("scripting.dictionary")
   
8.         For i = 2 To UBound(arr)
   
9.            
   
10.                 If Len(arr(i, 2)) > 0 Then
    
11.                  
    
12.                   .Item(CStr(arr(i, 1) & "/" & arr(i, 2))) = .Item(CStr(arr(i, 1) & "/" & arr(i, 2))) + arr(i, 3)
    
13.                  End If
    
14.         Next i
    
15.         
    
16.         [h2].Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
    
17.         Columns("H:H").Select
    
18.         Selection.TextToColumns Destination:=Range("k2"), DataType:=xlDelimited, _
    
19.         TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    
20.         Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    
21.         :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    
22.         Columns("H:H").Delete
    
23.         [j2:l2] = Array("日期", "代号", "金额")
    
24.         [l3].Resize(.Count, 1) = WorksheetFunction.Transpose(.items)
    
25.         
    
26.         End With
    
27.         Application.DisplayAlerts = True
    
28. End Sub

复制代码

FLY-VITAS

时间有点仓促，代码还有很多不完善的地方，但对楼主的需求应该是够了，原理是写入字典，可供楼主参考一下

FLY-VITAS

回家重新写了一个，代码如下，手机码字，格式可能不太对Sub 分类汇总()
    Dim rng As Range, arr, i As Integer
    arr = ActiveSheet.Range(Range("a1"), Cells(Rows.Count, 3).End(xlUp)).Value
    Application.DisplayAlerts = False
   
   On Error Resume Next
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr)
            If Len(arr(i, 2)) > 0 Then
                .Item(CStr(arr(i, 1) & "／" & arr(i, 2))) = .Item(CStr(arr(i, 1) & "／" & arr(i, 2))) + arr(i, 3)
            End If
        Next i
        
    Set rng = Application.InputBox("请选择数据存放区域", "指定区域", , , , , , 8)
        If Err <> 0 Then Exit Sub
        '对输出数据部分清零
       ' rng(1).Offset(0, 3).EntireColumn.Clear
        rng(1).Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
       '对数据分列
    rng(1).CurrentRegion.TextToColumns Destination:=rng(1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="／", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
   
        rng(1).Offset(0, 2).Resize(.Count, 1) =WorksheetFunction.Transpose(.items)
        rng(1).CurrentRegion.Borders.LineStyle = 1
        Application.DisplayAlerts = True
     End With
End Sub

x007file

不用编程的

1、排序  主序“日期”，副序“代号”
2、做数据透视表   行区：日期，代号；数据区：金额     （隐藏不必要的合计列，可以得到一样的效果）