批量提取数据

jx928867128

数据批量提取.rar (77.35 KB, 下载次数: 23)

2024-4-23 07:10 上传

点击文件名下载附件

3190496160

这个问题，适合初学者练练手，

chxw68

1. Sub test()
   
2.     Dim r%, i%, c%, j%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     With Worksheets("汇总")
   
9.         .AutoFilterMode = False
   
10.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.         c = .Cells(4, .Columns.Count).End(xlToLeft).Column
    
12.         ls = .Range("b3").MergeArea.Columns.Count
    
13.         arr = .Range("a3").Resize(r - 2, c)
    
14.         For i = 3 To UBound(arr)
    
15.             For j = 2 To UBound(arr, 2)
    
16.                 If InStr(arr(i, j), vbLf) <> 0 Then
    
17.                     xm = Split(arr(i, j), vbLf)
    
18.                     If InStr(arr(i, j), "/") = 0 Then
    
19.                         d(xm(1)) = Empty
    
20.                     Else
    
21.                         For k = 0 To UBound(xm)
    
22.                             xx = Split(xm(k), "/")
    
23.                             If UBound(xx) = 1 Then
    
24.                                 If xx(1) <> Empty Then
    
25.                                     d(xx(1)) = Empty
    
26.                                 End If
    
27.                             End If
    
28.                         Next
    
29.                     End If
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.         For Each aa In Array("固排", "禁排", "课程总表")
    
34.             .Range("a5:a" & r).Copy Worksheets(aa).Range("a5")
    
35.             .Range("a3").Resize(2, c).Copy Worksheets(aa).Range("a3")
    
36.         Next
    
37.         For Each aa In Array("同时课", "连课")
    
38.             .Range("a5:a" & r).Copy Worksheets(aa).Range("a2")
    
39.         Next
    
40.         For Each aa In Array("教师节次限制", "教师指定节次不能同时有课")
    
41.             .Range("b4").Resize(1, ls).Copy Worksheets(aa).Range("b1")
    
42.             Worksheets(aa).Range("a2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
43.         Next
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "数据提取完毕！"
    
47. End Sub
    

复制代码

chxw68

参与一下。

jx928867128

chxw68 发表于 2024-4-23 07:45
参与一下。

万分感谢老师的多次出手帮忙，再次感谢

jx928867128

chxw68 发表于 2024-4-23 07:45
参与一下。

数据批量提取（增加了2个表）.zip (91.56 KB, 下载次数: 1)

2024-4-23 11:06 上传

点击文件名下载附件

老师好，这个提取代码我还有2个表也想一起提取并填写，不知道方便帮我再修改下吗（如果是单双周课，课时数填写0.5，那2个表中的课程名与班级名也需要程序自动填写）

chxw68

没有细细琢磨。

jx928867128

chxw68 发表于 2024-4-23 11:23
没有细细琢磨。

感谢，我先测试下，有问题再麻烦您

jx928867128

chxw68 发表于 2024-4-23 11:23
没有细细琢磨。

数据批量提取（增加了2个表，测试中发现的问题）.zip (109.1 KB, 下载次数: 2)

2024-4-23 14:29 上传

点击文件名下载附件

老师好，教师任课表我测试时发现行标题中有好多科目的任课重复出现了（如果同一班同一科目填写了2个或多个不同的老师，科目下的任课老师写成教师1/教师2的形式），班级课时也出现了同样的问题，麻烦您再抽空帮我看看好吗

chxw68

楼主的附件到处是坑！