[已解决]如何用代码把数据分类

HaiMi

附件 数据分类附件.rar (242.64 KB, 下载次数: 24)

2016-5-16 08:35 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2016-5-16 11:42

请看附件。数组定义+2行，问题就解决了。

跳转到最佳答案楼层

grf1973

1. Sub 分类()
   
2.     arr = Range("a1:j" & [a65536].End(3).Row)
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     bj = [L1]   '比较数
   
5.     For i = 1 To UBound(arr) Step 13     '13行为一单元
   
6.         For j = 2 To 7     '判断每单元各列各小组第一行是否与比较数相同
   
7.             If arr(i, j) = bj And arr(i + 3, j) = bj And arr(i + 6, j) = bj And arr(i + 9, j) = bj Then
   
8.                 d(j - 1) = d(j - 1) & "," & i    '如果相同，记录该单元首行进字典。字典以列数-1为key
   
9.             End If
   
10.         Next
    
11.     Next
    
12.     For j = 1 To 6
    
13.         If d.exists(j) Then
    
14.             Worksheets.Add after:=Sheets(Sheets.Count)
    
15.             With ActiveSheet
    
16.                 .Name = j
    
17.                 xrr = Split(d(j), ",")         '各单元首行组成的数组
    
18.                 n = 0
    
19.                 ReDim brr(1 To 13 * UBound(xrr), 1 To UBound(arr, 2))
    
20.                 For k = 1 To UBound(xrr)      '复原各单元首行，并以此开始13行录入数组brr
    
21.                     i = xrr(k)
    
22.                     For kk = 0 To 12
    
23.                         n = n + 1
    
24.                         For jj = 1 To UBound(arr, 2)
    
25.                             brr(n, jj) = arr(i + kk, jj)
    
26.                         Next
    
27.                     Next
    
28.                 Next
    
29.                 .[a1].Resize(n, UBound(arr, 2)) = brr
    
30.                 .UsedRange.Columns.AutoFit
    
31.             End With
    
32.         End If
    
33.     Next
    
34.     Sheet1.Activate
    
35. End Sub
    

复制代码

grf1973

由于key为数值1--6

1. Sub 分类()
   
2.     arr = Range("a1:j" & [a65536].End(3).Row)
   
3.     Dim crr(1 To 6)    '记录满足条件的各单元首行
   
4.     bj = [L1]   '比较数
   
5.     For i = 1 To UBound(arr) Step 13     '13行为一单元
   
6.         For j = 2 To 7     '判断每单元各列各小组第一行是否与比较数相同
   
7.             If arr(i, j) = bj And arr(i + 3, j) = bj And arr(i + 6, j) = bj And arr(i + 9, j) = bj Then
   
8.                 crr(j - 1) = crr(j - 1) & "," & i    '如果相同，记录该单元首行进数组crr。
   
9.             End If
   
10.         Next
    
11.     Next
    
12.     For j = 1 To 6
    
13.         If crr(j) <> "" Then
    
14.             Worksheets.Add after:=Sheets(Sheets.Count)
    
15.             With ActiveSheet
    
16.                 .Name = j
    
17.                 xrr = Split(crr(j), ",")         '各单元首行组成的数组
    
18.                 n = 0
    
19.                 ReDim brr(1 To 13 * UBound(xrr), 1 To UBound(arr, 2))
    
20.                 For k = 1 To UBound(xrr)      '复原各单元首行，并以此开始13行录入数组brr
    
21.                     i = xrr(k)
    
22.                     For kk = 0 To 12
    
23.                         n = n + 1
    
24.                         For jj = 1 To UBound(arr, 2)
    
25.                             brr(n, jj) = arr(i + kk, jj)
    
26.                         Next
    
27.                     Next
    
28.                 Next
    
29.                 .[a1].Resize(n, UBound(arr, 2)) = brr
    
30.                 .UsedRange.Columns.AutoFit
    
31.             End With
    
32.         End If
    
33.     Next
    
34.     Sheet1.Activate
    
35. End Sub

复制代码

，所以可以用数组代替字典。

HaiMi

grf1973 发表于 2016-5-16 11:07
由于key为数值1--6，所以可以用数组代替字典。

老师你好，谢谢帮助。试了一下，有些运行正常，有些运行不正常。比如下面的附件：

输入4后，表1－－－表5正常，到表6时，出错。

附件 数据分类附件aa.rar (257.36 KB, 下载次数: 2)

2016-5-16 11:25 上传

点击文件名下载附件

grf1973

第一句把数组范围定大一点就行了。
arr = Range("a1:j" & [a1048576].End(3).Row + 2)   
因为还原的时候，每个单元13行，包括下面两个空行。

grf1973

请看附件。数组定义+2行，问题就解决了。