[已解决]多列多条件汇总

张雄友 · 发表于 2014-11-9 13:40

有二个问题：

一，标题能不能自动生成？
二，能否实现按前四个标题字段排序？

最佳答案

爱疯

2014-11-9 14:11

Sub 多列多条件汇总()
Range("A:F").ClearContents
Application.ScreenUpdating = False
Dim dc As Object, arr, i&, j%, s&, k, w
Set dc = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a2:f" & Sheet1.Range("a65536").End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 1 To UBound(arr)
      k = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
      w = dc(k)
      If w = "" Then
         s = s + 1
         For j = 1 To 6
            brr(s, j) = arr(i, j)
         Next
         dc(k) = s
         w = s
      Else
         For j = 5 To 6
            brr(w, j) = brr(w, j) + arr(i, j)
         Next
      End If
Next
[a1:f1] = Sheet1.[a1:f1].Value
[a2].Resize(s, 6) = brr
Range("a1").CurrentRegion.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
Range("a1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
                                 Key2:=Range("B1"), Order2:=xlAscending, _
                                 Key3:=Range("C1"), Order3:=xlAscending, _
                                 Header:=xlYes
Application.ScreenUpdating = True
End Sub

先按d排序再依次按a,b,c，相当于依次按a,b,c,d来排

跳转到最佳答案楼层

hyfire2008 · 发表于 2014-11-9 13:59

lz，可否把需要解决的问题描述清楚，估计没人能看懂你需要什么。

张雄友 · 发表于 2014-11-9 14:03

本帖最后由张雄友于 2014-11-9 14:06 编辑

hyfire2008 发表于 2014-11-9 13:59
lz，可否把需要解决的问题描述清楚，估计没人能看懂你需要什么。

有二个问题：

一，标题能不能自动生成？
二，能否实现按前四个标题字段排序？

附件效果看了没有？就是不是按源表出现的先后顺序，而是相同的排列在一起，像数据透视那样。

爱疯 · 发表于 2014-11-9 14:11

Sub 多列多条件汇总()
Range("A:F").ClearContents
Application.ScreenUpdating = False
Dim dc As Object, arr, i&, j%, s&, k, w
Set dc = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a2:f" & Sheet1.Range("a65536").End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 1 To UBound(arr)
      k = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)
      w = dc(k)
      If w = "" Then
         s = s + 1
         For j = 1 To 6
            brr(s, j) = arr(i, j)
         Next
         dc(k) = s
         w = s
      Else
         For j = 5 To 6
            brr(w, j) = brr(w, j) + arr(i, j)
         Next
      End If
Next
[a1:f1] = Sheet1.[a1:f1].Value
[a2].Resize(s, 6) = brr
Range("a1").CurrentRegion.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
Range("a1").CurrentRegion.Sort Key1:=Range("A1"), Order1:=xlAscending, _
                                 Key2:=Range("B1"), Order2:=xlAscending, _
                                 Key3:=Range("C1"), Order3:=xlAscending, _
                                 Header:=xlYes
Application.ScreenUpdating = True
End Sub

先按d排序再依次按a,b,c，相当于依次按a,b,c,d来排

xdragon · 发表于 2014-11-9 14:12

Sub 多列多条件汇总()
Range("a2:f65536").ClearContents
Application.ScreenUpdating = False
Dim dc As Object, arr, i&, j%, s&, w, k%, tmp
Set dc = CreateObject("scripting.dictionary")
arr = Sheet1.Range("a1:f" & Sheet1.Range("a65536").End(3).Row)
ReDim brr(UBound(arr) - 1, 1 To 6)
For i = 1 To UBound(arr, 2)
brr(0, i) = arr(1, i)
Next
For i = 2 To UBound(arr)
w = dc(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4))
If w = "" Then
s = s + 1
For j = 1 To 6
brr(s, j) = arr(i, j)
Next
dc(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)) = s
w = s
Else
For j = 5 To 6
brr(w, j) = brr(w, j) + arr(i, j)
Next
End If
Next
ReDim tmp(1 To UBound(brr, 2))
For i = 1 To s
For j = 1 To s - i + 1
If brr(j, 1) & "|" & brr(j, 2) & "|" & brr(j, 3) & "|" & brr(j, 4) > brr(j + 1, 1) & "|" & brr(j + 1, 2) & "|" & brr(j + 1, 3) & "|" & brr(j + 1, 4) Then
For k = 1 To UBound(brr, 2)
tmp(k) = brr(j, k)
brr(j, k) = brr(j + 1, k)
brr(j + 1, k) = tmp(k)
Next
End If
Next
Next
[a1].Resize(s + 1, 6) = brr
Application.ScreenUpdating = True
End Sub

复制代码

中文的排序好像效果不怎么好。。。我测试了下，"上海"<"北京"

张雄友 · 发表于 2014-11-9 14:22

爱疯发表于 2014-11-9 14:11
Sub 多列多条件汇总()
Range("A:F").ClearContents
Application.ScreenUpdating = False

03版最多可以按3个条件排序，如果有5，6，，，个条件不是行不通了？

张雄友 · 发表于 2014-11-9 14:23

xdragon 发表于 2014-11-9 14:12
中文的排序好像效果不怎么好。。。我测试了下，"上海"

是的，就是不能达到数据透视那样的顺序效果。

爱疯 · 发表于 2014-11-9 14:35

张雄友发表于 2014-11-9 14:22
03版最多可以按3个条件排序，如果有5，6，，，个条件不是行不通了？

多余3个，比如希望按a,b,c,d,e,f来排，那么执行或操作时就依次按f,e,d,c,b,a，一次排1个或多个，直到倒着排完。
07以后可直接添加很多个

Excel2003中,超过3个关键字的排序
http://www.excelpx.com/thread-123688-1-1.html

张雄友 · 发表于 2014-11-9 15:10

爱疯发表于 2014-11-9 14:35
多余3个，比如希望按a,b,c,d,e,f来排，那么执行或操作时就依次按f,e,d,c,b,a，一次排1个或多个，直到倒着 ...

哦，您的代码简化过，直接这样就明白了。

Range("A1").CurrentRegion.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes
Range("A1").CurrentRegion.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes
Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Order2:=xlAscending, Header:=xlYes
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Order3:=xlAscending, Header:=xlYes

张雄友 · 发表于 2014-11-9 15:15

爱疯发表于 2014-11-9 14:11
Sub 多列多条件汇总()
Range("A:F").ClearContents
Application.ScreenUpdating = False

先按d排序再依次按a,b,c，相当于依次按a,b,c,d来排。

像我这种水平不是一下子能理解的。

		自动登录	找回密码
密码			注册

[已解决]多列多条件汇总

评分