求助代码修改

ykcbf1100

458863601 发表于 2024-3-25 16:08
我添加你的QQ了，可以通过帮我看看吗？

在这里说吧。你又不付费。
只要你需求说的明白，可以免费给你做。

3190496160

Sub 合并工作表()
Application.ScreenUpdating = False
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set ww = ThisWorkbook
With Sheets("班级表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        d(ar(i, 1)) = ""
    End If
Next i
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 1 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
fileName = Application.GetOpenFilename("Excel 文件 (*.xls*),*.xls*")
If fileName = False Then MsgBox "您没有选择文件！": End
f = fileName
Set wb = Workbooks.Open(f, 0)
For Each sht In wb.Worksheets
    If d.exists(sht.Name) Then
        sht.Copy after:=ww.Sheets(ww.Sheets.Count)
    End If
Next sht
wb.Close False
Application.ScreenUpdating = True
MsgBox "数据提取完毕!", 64, "提示"
End Sub

3190496160

汇总表.rar (34.22 KB, 下载次数: 2)

2024-3-25 16:21 上传

点击文件名下载附件

458863601

ykcbf1100 发表于 2024-3-25 16:08
汇总表效果图呢？

在执教者提取对应班级的教师，

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.25
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set Sh = ThisWorkbook.Sheets("汇总表")
   
6.     With Sheets("班级表")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         For i = 2 To r
   
9.             s = .Cells(i, 1)
   
10.             d(s) = ""
    
11.         Next
    
12.     End With
    
13.     ReDim brr(1 To 10000, 1 To 10)
    
14.     p = ThisWorkbook.Path & ""
    
15.     With Application.FileDialog(msoFileDialogFilePicker)
    
16.         .InitialFileName = p
    
17.         .Title = "请选择对应Excel文件"
    
18.         .AllowMultiSelect = False
    
19.         .Filters.Clear
    
20.         .Filters.Add "Excel文件", "*.xls*"
    
21.         If .Show Then f = .SelectedItems(1) Else Exit Sub
    
22.     End With
    
23.     Set wb = Workbooks.Open(f, 0)
    
24.     For Each sht In wb.Sheets
    
25.         s = sht.Name
    
26.         If d.exists(s) Then
    
27.             n = n + 1
    
28.             With sht
    
29.                 r = .Cells(Rows.Count, 3).End(3).Row
    
30.                 fn = .[a13].Value
    
31.                 arr = .Range("a15:g" & r)
    
32.                 If n = 1 Then zrr = .[a14].Resize(1, 7)
    
33.             End With
    
34.             For i = 1 To UBound(arr)
    
35.                 If arr(i, 3) <> Empty Then
    
36.                     m = m + 1
    
37.                     brr(m, 1) = fn
    
38.                     For j = 2 To UBound(arr, 2)
    
39.                         brr(m, j) = arr(i, j)
    
40.                     Next
    
41.                 End If
    
42.             Next
    
43.         End If
    
44.     Next
    
45.     wb.Close False
    
46.     With Sh
    
47.         .[a1].Resize(1, UBound(zrr, 2)) = zrr
    
48.         .[a2].Resize(m, UBound(arr, 2)) = brr
    
49.         .[a1].Resize(1, UBound(zrr, 2)).Interior.Color = 49407
    
50.         With .[a1].Resize(m + 1, UBound(arr, 2))
    
51.             .Borders.LineStyle = 1
    
52.             .HorizontalAlignment = xlCenter  '//列居中
    
53.             .VerticalAlignment = xlCenter
    
54.         End With
    
55.     End With
    
56.     Set d = Nothing
    
57.     Application.ScreenUpdating = True
    
58.     MsgBox "OK！"
    
59. End Sub
    
60. 
    

复制代码