[已解决]想通过VBA快捷排序

mind1238

原表格是规格不一，厚度不一。首列是厚度，有多个厚度。举例：12、15、18、20厚。厚度所对应的行分别有数值，代表件数。
现在要按等级规格厚度分类汇总
统计数据前必须先排序，我之前的做法是，先在首例厚度进行筛选，筛选空值不显示，然后有数据的会全出来，然后再人工在旁边插入一行，人工一个一个的手工输厚度及件数。
因为每天要统计表格数据，而且工作量大，现在想要通过VBA的方式快速排序。
求大家指教，在线等，谢谢。

最佳答案

月排行榜 / 总排行榜

lichuanboy44

2016-2-27 11:41

mind1238 发表于 2016-2-27 11:19
先谢谢你为我解答，意思大概是这样的。
但是我现在还有一个问题，就是如果我后面还跟着一列备注的话，能 ...

严格说，你这个是分类汇总，不是什么排序
你应该将原始表，希望得到的结果表，一次性告知清楚，源数据也在变，程序调整还是麻烦的，除非你自己懂编程

1. Sub tr()
   
2.     Dim br
   
3.     p = 1
   
4.     n = [B65536].End(3).Row
   
5.     ar = Range("A3:O" & n)
   
6.     cr = Range("A2:K2")
   
7.     ReDim br(1 To 15, 1 To p)
   
8.     For i = 1 To n - 2
   
9.         sr = ar(i, 1)
   
10.         For j = 4 To 11
    
11.             js = ar(i, j)
    
12.             hd = cr(1, j)
    
13.             If js <> "" Then
    
14.                 br(j, p) = js
    
15.                 br(12, p) = hd: br(13, p) = js
    
16.                  br(14, p) = ar(i, 14): br(15, p) = ar(i, 15)
    
17.                 For k = 1 To 3
    
18.                     br(k, p) = ar(i, k)
    
19.                 Next
    
20.                 p = p + 1
    
21.                 ReDim Preserve br(1 To 15, 1 To p)
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     With Worksheets(2)
    
26.       .[A3:P5000].ClearContents
    
27.       .[A3].Resize(p, 15) = WorksheetFunction.Transpose(br)
    
28.       .Activate
    
29.     End With
    
30. End Sub

复制代码

跳转到最佳答案楼层

lichuanboy44

调试成功

1. Sub tr()
   
2. '10:22
   
3.     Dim br
   
4.     p = 1
   
5.     n = [C65536].End(3).Row
   
6.     ar = Range("A3:L" & n)
   
7.     cr = Range("A2:L2")
   
8.     ReDim br(1 To 14, 1 To p)
   
9.     For i = 1 To n - 2
   
10.         sr = ar(i, 4)
    
11.         For j = 5 To 12
    
12.             js = ar(i, j)
    
13.             hd = cr(1, j)
    
14.             If js <> "" Then
    
15.                 br(j, p) = js
    
16.                 br(13, p) = hd: br(14, p) = js
    
17.                 For k = 1 To 4
    
18.                     br(k, p) = ar(i, k)
    
19.                 Next
    
20.                 p = p + 1
    
21.                 ReDim Preserve br(1 To 14, 1 To p)
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     [N3:AA5000].ClearContents
    
26.     [N3].Resize(p, 14) = WorksheetFunction.Transpose(br)
    
27. End Sub
    

复制代码

mind1238

lichuanboy44 发表于 2016-2-27 11:04
调试成功

先谢谢你为我解答，意思大概是这样的。
但是我现在还有一个问题，就是如果我后面还跟着一列备注的话，能不能把备注也一齐排序的？
请查看附件，我上传附件

lichuanboy44

mind1238 发表于 2016-2-27 11:19
先谢谢你为我解答，意思大概是这样的。
但是我现在还有一个问题，就是如果我后面还跟着一列备注的话，能 ...

严格说，你这个是分类汇总，不是什么排序
你应该将原始表，希望得到的结果表，一次性告知清楚，源数据也在变，程序调整还是麻烦的，除非你自己懂编程

1. Sub tr()
   
2.     Dim br
   
3.     p = 1
   
4.     n = [B65536].End(3).Row
   
5.     ar = Range("A3:O" & n)
   
6.     cr = Range("A2:K2")
   
7.     ReDim br(1 To 15, 1 To p)
   
8.     For i = 1 To n - 2
   
9.         sr = ar(i, 1)
   
10.         For j = 4 To 11
    
11.             js = ar(i, j)
    
12.             hd = cr(1, j)
    
13.             If js <> "" Then
    
14.                 br(j, p) = js
    
15.                 br(12, p) = hd: br(13, p) = js
    
16.                  br(14, p) = ar(i, 14): br(15, p) = ar(i, 15)
    
17.                 For k = 1 To 3
    
18.                     br(k, p) = ar(i, k)
    
19.                 Next
    
20.                 p = p + 1
    
21.                 ReDim Preserve br(1 To 15, 1 To p)
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     With Worksheets(2)
    
26.       .[A3:P5000].ClearContents
    
27.       .[A3].Resize(p, 15) = WorksheetFunction.Transpose(br)
    
28.       .Activate
    
29.     End With
    
30. End Sub

复制代码

mind1238

lichuanboy44 发表于 2016-2-27 11:41
严格说，你这个是分类汇总，不是什么排序
你应该将原始表，希望得到的结果表，一次性告知清楚，源数据也 ...

是的，谢谢你。
我会注意我的表达方式的
谢谢，太感谢了