[已解决]vba提取不重复值

武林长风

从一年级工作表的B列里提取不重复的年班到一年级汇总的A3以下单元格里。从B列开始用函数公式计算该学校该年级每一科的成绩。其它年级的一样。点击提取年班按钮同时完成1-6年级的提取。 新建文件夹.rar (274.27 KB, 下载次数: 7)

2015-7-20 00:15 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2015-7-20 15:00

1. Sub 提取年班()
   
2.     Dim sh As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For Each sh In Worksheets
   
5.         If sh.Name Like "*年级" Then
   
6.             r = sh.[b65536].End(3).Row
   
7.             arr = sh.Range("b1:b" & r)
   
8.             For i = 2 To UBound(arr)
   
9.                 If Trim(arr(i, 1)) <> "学校" Then
   
10.                     d(arr(i, 1)) = ""
    
11.                 End If
    
12.             Next
    
13.             With Sheets(sh.Name & "汇总")
    
14.                 .[a3:a1000].ClearContents
    
15.                 .[a3].Resize(d.Count) = Application.Transpose(d.keys)
    
16.             End With
    
17.             d.RemoveAll
    
18.         End If
    
19.     Next
    
20. End Sub
    

复制代码

跳转到最佳答案楼层

武林长风

一年级汇总里的提取：

上清宫主

录个高级筛选的宏改改就成了

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, brr, d, i%, j&, k%
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 2 To 7
   
6.     arr = Sheets(i).Range("a1").CurrentRegion
   
7.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 3)
   
8.     s = 0
   
9.     Sheets(i).[e1:m1].Copy Sheets(i + 6).[b2]
   
10.     For j = 2 To UBound(arr)
    
11.         If arr(j, 2) = "学校" Then GoTo 100
    
12.         If Not d.exists(arr(j, 2)) Then
    
13.             s = s + 1
    
14.             d(arr(j, 2)) = s
    
15.             For k = 5 To UBound(arr, 2)
    
16.                 brr(s, 1) = arr(j, 2)
    
17.                 brr(s, k - 3) = arr(j, k)
    
18.             Next
    
19.         Else
    
20.             n = d(arr(j, 2))
    
21.             For k = 5 To UBound(arr, 2)
    
22.                 brr(n, k - 3) = brr(n, k - 3) + arr(j, k)
    
23.             Next
    
24.         End If
    
25. 100:
    
26.     Next
    
27.     Sheets(i + 6).Range("a3").Resize(s, UBound(brr, 2)) = brr
    
28.     d.RemoveAll
    
29. Next
    
30. End Sub

复制代码

dsmch

………………

武林长风

dsmch 发表于 2015-7-20 08:40
………………

只提取学校年班，不要成绩。见2楼。

武林长风

上清宫主 发表于 2015-7-20 08:34
录个高级筛选的宏改改就成了

录制宏还行，可是不会改。

grf1973

1. Sub 提取年班()
   
2.     Dim sh As Worksheet
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For Each sh In Worksheets
   
5.         If sh.Name Like "*年级" Then
   
6.             r = sh.[b65536].End(3).Row
   
7.             arr = sh.Range("b1:b" & r)
   
8.             For i = 2 To UBound(arr)
   
9.                 If Trim(arr(i, 1)) <> "学校" Then
   
10.                     d(arr(i, 1)) = ""
    
11.                 End If
    
12.             Next
    
13.             With Sheets(sh.Name & "汇总")
    
14.                 .[a3:a1000].ClearContents
    
15.                 .[a3].Resize(d.Count) = Application.Transpose(d.keys)
    
16.             End With
    
17.             d.RemoveAll
    
18.         End If
    
19.     Next
    
20. End Sub
    

复制代码