将表格中同名的教师按一定的格式汇总

sxdmsz

将表格中同名的教师按一定的格式汇总，具体见表格中红色部分。谢谢。 1.rar (7.22 KB, 下载次数: 15)

2024-1-16 20:45 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.16
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     arr = Range("a1:h" & r)
   
6.     For i = 2 To UBound(arr)
   
7.         s = arr(i, 2)
   
8.         d1(s) = s
   
9.         ss = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
   
10.         If Not d.exists(s) Then
    
11.             d(s) = arr(i, 5) & ":" & arr(i, 3) & arr(i, 4) & "班" & arr(i, 6) & "人,周课时" & arr(i, 7) & "节；"
    
12.         Else
    
13.             d(s) = d(s) & arr(i, 5) & ":" & arr(i, 3) & arr(i, 4) & "班" & arr(i, 6) & "人,周课时" & arr(i, 7) & "节" & IIf(arr(i, 8) <> Empty, "；总课时" & arr(i, 8) & "节。", "。")
    
14.         End If
    
15.     Next
    
16.     [o2:p1000] = ""
    
17.     [o2].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.Items)
    
18.     arr = [o2].Resize(d1.Count, 2)
    
19.     For i = 1 To UBound(arr)
    
20.         s = arr(i, 1)
    
21.         arr(i, 2) = d(s)
    
22.     Next
    
23.     [o2].Resize(d1.Count, 2) = arr
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

shiruiqiang

============

qline302

Sub CombineX()

Dim dic As Object, arrX As Variant, i As Integer, strValue As String

Set dic = CreateObject("scripting.dictionary")
arrX = Range("A1").CurrentRegion

For i = 2 To UBound(arrX)
    strValue = arrX(i, 5) & ":" & arrX(i, 3) & arrX(i, 4) & "班" & arrX(i, 6) & "人，周课时" & arrX(i, 7) & "节" & IIf(arrX(i, 8) = "", "；", "，总课时" & arrX(i, 8) & "节。")
    If dic.exists(arrX(i, 2)) Then
        dic(arrX(i, 2)) = dic(arrX(i, 2)) & strValue
      Else
        dic.Add arrX(i, 2), strValue
    End If
Next i

Range("O7").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)
Range("P7").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)

Set dic = Nothing

End Sub

680926

Sub t()
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    Dim arr
    arr = Range("a1").CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.exists(arr(i, 2)) Then
            d(arr(i, 2)) = arr(i, 5) & ":" & arr(i, 3) & arr(i, 4) & "班" & arr(i, 6) & "人，" & arr(1, 7) & arr(i, 7) & "节；"
            x = d(arr(i, 2))
        Else
            If arr(i, 8) <> "" Then
                d(arr(i, 2)) = d(arr(i, 2)) & arr(i, 3) & arr(i, 4) & "班" & arr(i, 6) & "人，" & arr(1, 7) & arr(i, 7) & "节；" _
            & arr(1, 8) & arr(i, 8) & "节。"
            Else
                d(arr(i, 2)) = d(arr(i, 2)) & arr(i, 3) & arr(i, 4) & "班" & arr(i, 6) & "人，" & arr(1, 7) & arr(i, 7) & "节；"
            End If
        End If
    Next
    [m1].Resize(d.Count, 2) = Application.WorksheetFunction.Transpose(Array(d.keys, d.items))
End Sub