数据提取

wang-way

1. function 分类汇总(){
   
2.         let sht=ThisWorkbook.Worksheets.Item('总功课表');
   
3.         let sht2=ThisWorkbook.Worksheets.Item('任课节数汇总表');
   
4.         sht2.Cells.Clear();
   
5.         let arr=sht.Range('A5').CurrentRegion.Value2.slice(2);
   
6.         let all=[];
   
7.         for(let r of arr)
   
8.         {
   
9.                 let tmp=[];
   
10.                 tmp.push(r[0]);//班级推入数组
    
11.                 let d=new Map();
    
12.                 for(let c of r.slice(1))
    
13.                 {
    
14.                         d[c]??=0;
    
15.                         d[c]+=1;
    
16.                 }
    
17.                 for(k in d){tmp.push(k,d[k]);}
    
18.                 all.push(tmp);//整行数据推入数组       
    
19.         }
    
20.        
    
21.         let h=[];
    
22.         for(let j=0;j<12;j++){
    
23.                 h.push('教师'+(j+1),'节数');
    
24.         }
    
25.        
    
26.         h.unshift('-');
    
27.         all.unshift(h);//添加表头
    
28.        
    
29.         sht2.Cells(1,1).Resize(all.length,all[0].length).Value2=all;
    
30. }

复制代码

jx928867128

ykcbf1100 发表于 2024-5-6 08:40
参与一下。。。

问题（测试时发现的问题）.rar (28.73 KB, 下载次数: 3)

2024-5-6 18:17 上传

点击文件名下载附件

再次感谢老师的帮忙，测试时发现，我把第1个班级中老师的名字改成了AAA和bbb时，这时1班应有14位老师，但提取时1班还是12位老师。

ykcbf1100

jx928867128 发表于 2024-5-6 18:17
再次感谢老师的帮忙，测试时发现，我把第1个班级中老师的名字改成了AAA和bbb时，这时1班应有14位老师，但 ...

你这个表感觉设计得有点问题，列应该用姓名做标题，这样就可以无限扩展。你现在用教师1、2、3区别的话，每个班老师可能有多有少就不好统一了。

ykcbf1100

表结构改了一下，仅供参考。。。

不再跟进。

1. Sub ykcbf()  '//2024.5.6
   
2.     Dim arr, brr, d, s
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("班级任课教师及任课节数汇总表")
   
7.     m = 1: n = 1
   
8.     On Error Resume Next
   
9.     With Sheets("总功课表（教师名字版）")
   
10.         r = .Cells(Rows.Count, 1).End(3).Row
    
11.         col = .UsedRange.Columns.Count
    
12.         arr = .[a1].Resize(r, col)
    
13.         ReDim brr(1 To UBound(arr), 1 To 300)
    
14.         For i = 2 To UBound(arr)
    
15.             If arr(i, 1) <> Empty Then
    
16.                 s = arr(i, 1)
    
17.                 If Not d.exists(s) Then
    
18.                     m = m + 1
    
19.                     d(s) = m
    
20.                     brr(m, 1) = s
    
21.                 End If
    
22.                 r = d(arr(i, 1))
    
23.                 For j = 2 To UBound(arr, 2)
    
24.                     If arr(i, j) <> Empty Then
    
25.                         s = Trim(arr(i, j))
    
26.                         If Not d.exists(s) Then
    
27.                             n = n + 1
    
28.                             d(s) = n
    
29.                             brr(1, n) = s
    
30.                         End If
    
31.                         c = d(Trim(arr(i, j)))
    
32.                         brr(r, c) = brr(r, c) + 1
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.         Next
    
37.     End With
    
38.     With sh
    
39.         .UsedRange.Clear
    
40.         .[a1].Resize(m, n) = brr
    
41.         .[a1].Resize(1, n).Interior.Color = 49407
    
42.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
43.         ActiveWindow.DisplayZeros = False
    
44.         Set Rng = .[a1].Resize(m, n)
    
45.         With Rng
    
46.             .Borders.LineStyle = 1
    
47.             .HorizontalAlignment = xlCenter
    
48.             .VerticalAlignment = xlCenter
    
49.             With .Font
    
50.                 .Name = "微软雅黑"
    
51.                 .Size = 11
    
52.             End With
    
53.         End With
    
54.     End With
    
55.     Set d = Nothing
    
56.     Application.ScreenUpdating = True
    
57. End Sub
    

复制代码

jx928867128

ykcbf1100 发表于 2024-5-6 19:58
表结构改了一下，仅供参考。。。

不再跟进。

谢谢老师的再次帮忙，领导屁事多，就是要那种格式的表格交他看，我们也没什么办法，如果不好实现，我只能再人工统计了

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr, bt()
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("总功课表（教师名字版）")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         c = .Cells(4, .Columns.Count).End(xlToLeft).Column
   
9.         arr = .Range("a5").Resize(r - 4, c)
   
10.     End With
    
11.     ReDim brr(1 To UBound(arr), 1 To 100)
    
12.     x = 0
    
13.     For i = 1 To UBound(arr)
    
14.         d.RemoveAll
    
15.         For j = 2 To UBound(arr, 2)
    
16.             If Len(arr(i, j)) <> 0 Then
    
17.                 d(arr(i, j)) = d(arr(i, j)) + 1
    
18.             End If
    
19.         Next
    
20.         brr(i, 1) = arr(i, 1)
    
21.         n = 2
    
22.         For Each aa In d.keys
    
23.             brr(i, n) = aa
    
24.             brr(i, n + 1) = d(aa)
    
25.             n = n + 2
    
26.         Next
    
27.         If x < n - 1 Then
    
28.             x = n - 1
    
29.         End If
    
30.     Next
    
31.     ReDim bt(1 To x)
    
32.     n = 1
    
33.     For j = 2 To UBound(bt) Step 2
    
34.         bt(j) = "教师" & n
    
35.         bt(j + 1) = "节数"
    
36.         n = n + 1
    
37.     Next
    
38.     With Worksheets("班级任课教师及任课节数汇总表")
    
39.         .Cells.Clear
    
40.         .Range("a1").Resize(1, UBound(bt)) = bt
    
41.         With .Range("a2").Resize(UBound(brr), x)
    
42.             .Value = brr
    
43.         End With
    
44.         With .Range("a1").Resize(1 + UBound(brr), x)
    
45.             .Borders.LineStyle = xlContinuous
    
46.             With .Font
    
47.                 .Name = "微软雅黑"
    
48.                 .Size = 10
    
49.             End With
    
50.         End With
    
51.         With .UsedRange
    
52.             .HorizontalAlignment = xlCenter
    
53.             .VerticalAlignment = xlCenter
    
54.         End With
    
55.     End With
    
56. End Sub
    

复制代码

chxw68

参与一下。

jx928867128

leeson7502 发表于 2024-5-6 22:18
参与一下，两种格式，一种教师按表格顺序，一种按汉语拼音排序。

非常感谢大神的帮忙，再次感谢，我还有一问题一年多都没解决，不知您方便抽空看看好吗https://club.excelhome.net/threa ... tml?_dsign=96a06c86