请大神帮忙编写个VBA，开学减轻工作量

烟火孤星泪

已完成，谢谢

烟火孤星泪

有大神有空，帮忙看看吗

liulang0808

Sub 按钮12_Click()
    arr = Sheets("学生名单").[a1].CurrentRegion
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    For j = 2 To UBound(arr)
        x = Format(arr(j, 6), "00") & "栋"
        If Not d.exists(x) Then
            Set d(x) = CreateObject("scripting.dictionary")
        End If
        If Not d(x).exists(arr(j, 7) & "") Then
            Set d(x)(arr(j, 7) & "") = CreateObject("scripting.dictionary")
        End If
        d(x)(arr(j, 7) & "")(j) = j
    Next j
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sh In Sheets
        If d.exists(sh.Name & "") Then
            For Each cmt In sh.Comments
                cmt.Delete
            Next cmt
            r = sh.Cells(Rows.Count, 1).End(3).Row
            For j = 3 To r Step 4
                For i = sh.Cells(j, Columns.Count).End(xlToLeft).Column To 2 Step -1
                    If d(sh.Name & "").exists(sh.Cells(j, i) & "") Then
                        dd.RemoveAll
                        y1 = sh.Name & ""
                        y2 = sh.Cells(j, i) & ""
                        y3 = d(sh.Name & "")(sh.Cells(j, i) & "").Count
                        sh.Cells(j + 1, i) = d(sh.Name & "")(sh.Cells(j, i) & "").Count
                        For Each k In d(sh.Name & "")(sh.Cells(j, i) & "").keys
                            dd(arr(k, 2)) = dd(arr(k, 2)) & Chr(10) & arr(k, 3) & "-" & arr(k, 8)
                        Next k
                        If dd.Count = 1 Then
                            sh.Cells(j + 2, i) = dd.keys()(0)
                        Else
                            sh.Cells(j + 2, i) = Join(dd.keys, ",")
                            sh.Cells(j + 2, i).Interior.ColorIndex = 6
                        End If
                        If sh.Cells(j + 2, i) = sh.Cells(j + 2, i + 1) Then
                            sh.Cells(j + 2, i).Resize(1, 2).Merge
                        End If
                        
                        str1 = ""
                        For Each k In dd.keys
                            str1 = str1 & Chr(10) & k & Chr(10) & dd(k)
                        Next k
                        sh.Cells(j, i).AddComment
                        sh.Cells(j, i).Comment.Visible = False
                        sh.Cells(j, i).Comment.Text Text:=str1
                    End If
                Next i
            Next j
        End If
    Next sh
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。。

烟火孤星泪

liulang0808 发表于 2024-9-3 11:07
供参考。。。。。。

那个批注框太小了，请问调哪里，可以调大一点？

chxw68

练习。没有写完，下午完善。

liulang0808

1. Sub 按钮12_Click()
   
2.     arr = Sheets("学生名单").[a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dd = CreateObject("scripting.dictionary")
   
5.     For j = 2 To UBound(arr)
   
6.         x = Format(arr(j, 6), "00") & "栋"
   
7.         If Not d.exists(x) Then
   
8.             Set d(x) = CreateObject("scripting.dictionary")
   
9.         End If
   
10.         If Not d(x).exists(arr(j, 7) & "") Then
    
11.             Set d(x)(arr(j, 7) & "") = CreateObject("scripting.dictionary")
    
12.         End If
    
13.         d(x)(arr(j, 7) & "")(j) = j
    
14.     Next j
    
15.     Application.ScreenUpdating = False
    
16.     Application.DisplayAlerts = False
    
17.     For Each sh In Sheets
    
18.         If d.exists(sh.Name & "") Then
    
19.             For Each cmt In sh.Comments
    
20.                 cmt.Delete
    
21.             Next cmt
    
22.             r = sh.Cells(Rows.Count, 1).End(3).Row
    
23.             For j = 3 To r Step 4
    
24.                 For i = sh.Cells(j, Columns.Count).End(xlToLeft).Column To 2 Step -1
    
25.                     If d(sh.Name & "").exists(sh.Cells(j, i) & "") Then
    
26.                         dd.RemoveAll
    
27.                         y1 = sh.Name & ""
    
28.                         y2 = sh.Cells(j, i) & ""
    
29.                         y3 = d(sh.Name & "")(sh.Cells(j, i) & "").Count
    
30.                         sh.Cells(j + 1, i) = d(sh.Name & "")(sh.Cells(j, i) & "").Count
    
31.                         For Each k In d(sh.Name & "")(sh.Cells(j, i) & "").keys
    
32.                             dd(arr(k, 2)) = dd(arr(k, 2)) & Chr(10) & arr(k, 3) & "-" & arr(k, 8)
    
33.                         Next k
    
34.                         If dd.Count = 1 Then
    
35.                             sh.Cells(j + 2, i) = dd.keys()(0)
    
36.                         Else
    
37.                             sh.Cells(j + 2, i) = Join(dd.keys, ",")
    
38.                             sh.Cells(j + 2, i).Interior.ColorIndex = 6
    
39.                         End If
    
40.                         If sh.Cells(j + 2, i) = sh.Cells(j + 2, i + 1) Then
    
41.                             sh.Cells(j + 2, i).Resize(1, 2).Merge
    
42.                         End If
    
43.                         
    
44.                         str1 = ""
    
45.                         For Each k In dd.keys
    
46.                             str1 = str1 & Chr(10) & k & Chr(10) & dd(k)
    
47.                         Next k
    
48.                         sh.Cells(j, i).AddComment
    
49.                         sh.Cells(j, i).Comment.Visible = False
    
50.                         sh.Cells(j, i).Comment.Text Text:=str1
    
51.                         sh.Cells(j, i).Comment.Shape.Height = 200
    
52.                     End If
    
53.                 Next i
    
54.             Next j
    
55.         End If
    
56.     Next sh
    
57.     Application.DisplayAlerts = True
    
58.     Application.ScreenUpdating = True
    
59. End Sub
    
60. 
    

复制代码

liulang0808

供参考。。。。。

chxw68

完成了。。。

烟火孤星泪

liulang0808 发表于 2024-9-3 12:51
供参考。。。。。

批注那里，同一个宿舍，有两个班的，是否可以第二个班跟第一个班的数据，分隔一行