用VBA数组按开始结束日期 实现分类统计汇总

laoau128

用VBA数组按开始结束日期   实现分类统计汇总

你改成这个就可以

laoau128

这一个谁来做一下

laoau128

再顶一次了

凌空一羽

用2个字典来做吧……

Sub lkyy()
Dim i%, j As Byte, s$, ar, br(), Star, Last
Set d = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
Star = Application.InputBox(Prompt:="输入开始日期", Type:=1)
Last = Application.InputBox(Prompt:="输入结束日期", Type:=1)
If Star > Last Then MsgBox "开始日期比结束日期大，你玩我啊？", 0, "提示"
ar = Range("a1").CurrentRegion
ReDim br(1 To UBound(ar), 1 To 3)
For i = 2 To UBound(ar)
    If ar(i, 1) >= Star And ar(i, 1) <= Last Then
        d(ar(i, 2)) = d(ar(i, 2)) + ar(i, 4)
        dic(ar(i, 2) & "," & ar(i, 3)) = dic(ar(i, 2) & "," & ar(i, 3)) + ar(i, 4)
    End If
Next
If d.Count = 0 Then MsgBox "开始日期-结束日期不在A列日期区间中，请检查", 0, "提示"
For i = 0 To d.Count - 1
    n = n + 1
    br(n, 1) = d.keys()(i)
    br(n, 2) = d.items()(i)
    For j = 0 To dic.Count - 1
        If d.keys()(i) = Split(dic.keys()(j), ",")(0) Then s = s & Split(dic.keys()(j), ",")(1) & dic.items()(j) & ","
    Next
    br(n, 3) = s: s = ""
Next
Application.DisplayAlerts = False
Range("g13:L100").ClearContents
[g13] = Star
[g14] = Last
Range("h13").Resize(n, 3) = br
Range("j13").Resize(n).TextToColumns comma:=True
[h13].Offset(n, 0) = "合计"
[i13].Offset(n, 0).Formula = "=sum(i13:i" & 13 + n - 1 & ")"
Application.DisplayAlerts = True
End Sub

凌空一羽

晕，又遇回复审核，请见附件

凌空一羽

再来一种方法


Sub lkyy2()
Dim i%, j As Byte, tol%, mx$, Star, Last, n As Byte, s$
Set d = CreateObject("Scripting.Dictionary")
Star = Application.InputBox(Prompt:="输入开始日期", Type:=1)
Last = Application.InputBox(Prompt:="输入结束日期", Type:=1)
If Star > Last Then MsgBox "开始日期比结束日期大，你玩我啊？", 0, "提示"
ar = Range("a1").CurrentRegion
ReDim br(1 To UBound(ar), 1 To 3)
For i = 2 To UBound(ar)
    Set d(ar(i, 2)) = CreateObject("Scripting.Dictionary")
Next
For i = 2 To UBound(ar)
    If ar(i, 1) >= Star And ar(i, 1) <= Last Then
        s = ar(i, 2)
        d(s)(ar(i, 3)) = d(s)(ar(i, 3)) + ar(i, 4)
    End If
Next
For i = 0 To d.Count - 1
    n = n + 1
    br(n, 1) = d.keys()(i)
    For j = 0 To d(d.keys()(i)).Count - 1
        mx = mx & d(d.keys()(i)).keys()(j) & d(d.keys()(i)).items()(j) & ","
        tol = tol + d(d.keys()(i)).items()(j)
    Next
    br(n, 2) = tol
    tol = 0
    br(n, 3) = mx
    mx = ""
Next
Application.DisplayAlerts = False
Range("g13:L100").ClearContents
[g13] = Star
[g14] = Last
Range("h13").Resize(n, 3) = br
Range("j13").Resize(n).TextToColumns comma:=True
[h13].Offset(n, 0) = "合计"
[i13].Offset(n, 0).Formula = "=sum(i13:i" & 13 + n - 1 & ")"
Application.DisplayAlerts = True
Set d = Nothing
End Sub

laoau128

凌空一羽 发表于 2017-5-31 23:00
再来一种方法

VBA数组用三种方法 用Instr和Like和Filter

http://club.excelhome.net/thread-1351012-1-1.html

yaozong

1. Sub yyy()
   
2. Dim dx, dy, arr, i&, j&, k&, m&, n&, x&, y&, s2$, s3$, sz&, x1, y1
   
3. Set dx = CreateObject("Scripting.Dictionary")
   
4. Set dy = CreateObject("Scripting.Dictionary")
   
5. arr = Range("a2", Cells(Rows.Count, 4).End(3)).Value
   
6. x1 = Application.Min(Application.Index(arr, 0, 1))
   
7. y1 = Application.Max(Application.Index(arr, 0, 1))
   
8. x = Application.InputBox(Prompt:="输入开始日期", Default:=x1, Type:=1)
   
9. y = Application.InputBox(Prompt:="输入结束日期", Default:=y1, Type:=1)
   
10. If x > y Then MsgBox "开始日期比结束日期大，你玩我啊？", 0, "提示"
    
11. ReDim brr(1 To UBound(arr) + 1, 1 To UBound(arr) + 2)
    
12. brr(1, 1) = "开始-结束": brr(1, 2) = "姓名": brr(1, 3) = "销售额合计"
    
13. brr(2, 1) = x: brr(3, 1) = y
    
14. m = 1: n = 3
    
15. For i = 1 To UBound(arr)
    
16.   If arr(i, 1) >= x And arr(i, 1) <= y Then
    
17.     s2 = arr(i, 2): s3 = arr(i, 3)
    
18.     If Not dy.exists(s2) Then
    
19.       m = m + 1
    
20.       dy(s2) = m
    
21.       brr(m, 2) = s2
    
22.       brr(m, 3) = arr(i, 4)
    
23.     Else
    
24.       brr(dy(s2), 3) = brr(dy(s2), 3) + arr(i, 4)
    
25.     End If
    
26.     If Not dx.exists(s3) Then
    
27.       n = n + 1
    
28.       dx(s3) = n
    
29.       brr(1, n) = s3
    
30.     End If
    
31.     brr(dy(s2), dx(s3)) = brr(dy(s2), dx(s3)) + arr(i, 4)
    
32.     sz = sz + arr(i, 4)
    
33.   End If
    
34. Next
    
35. brr(m + 1, 2) = "合计": brr(m + 1, 3) = sz
    
36. With [G1]
    
37.   .CurrentRegion.Borders.LineStyle = 0
    
38.   .CurrentRegion.ClearContents
    
39.   .Resize(m + 1, n) = brr
    
40.   .Resize(m + 1, n).Borders.LineStyle = 1
    
41. End With
    
42. End Sub

复制代码

yaozong

遇回复审核，请见附件       170610-你改成这个.rar (19.21 KB, 下载次数: 23)

2017-6-10 15:45 上传

点击文件名下载附件

laoau128

yaozong 发表于 2017-6-10 15:45
遇回复审核，请见附件

奇怪，你怎么挑困难题目来做，简单的题目你就不做了