教师名册提取代码(已解决)

jx928867128

请好心人帮忙写个教师名册提取代码：1、课程清单表中从A2开始填写了“教师|星期|节次”这种格式的内容，需要代码把第一个|前的教师提取出来，并去重复值，再复制到教师名册表中的B2进行粘贴，并填写好序号。2、当课程清单表中的数据增加或减少后、数据改变后（教师|星期|节次这种格式不会变）程序也能正确运行。 教师名册提取.rar (68.11 KB, 下载次数: 24)

2023-3-18 09:11 上传

点击文件名下载附件

wanghan519

来凑热闹，感觉perl单行式写在公式栏里真的爽啊，其实只用公式应该也可以

1. wps =UNIQUE(LEFT(A1:A13,FIND("|",A1:A13)-1))

复制代码

zxsea_7426

cjc209

Sub 字典数组法()
    Dim dic
    Set dic = CreateObject("scripting.dictionary")
    n = Sheet5.Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To n '源数据区行循环
        Key = Split(Sheet5.Cells(i, 1).Value, "|")(0) '关键字组合型
        If Not dic.exists(Key) And Key <> "" Then
            dic(Key) = dic.Count + 1
        End If
    Next
    Sheet2.Range("a2").Resize(10000, 2).ClearContents
    Sheet2.Range("a2").Resize(dic.Count, 2) = Application.Transpose(Array(dic.items, dic.keys))
End Sub

jx928867128

zxsea_7426 发表于 2023-3-18 09:33

谢谢老师帮忙，我抄了半天，还是出错，估计是抄时不正确，不知方便上传个附件吗

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, strName$, i&, r&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets("课程清单").[A1].CurrentRegion
    For i = 2 To UBound(ar)
        strName = Split(ar(i, 1), "|")(0)
        If strName <> "" Then
            If Not dic.exists(strName) Then
                r = r + 1
                dic(strName) = r
            End If
        End If
    Next i
   
    [A1].CurrentRegion.Offset(1).Clear
    [A2].Resize(dic.Count, 2) = Application.Transpose(Array(dic.items, dic.keys))
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

请参考。。。

3190496160

Sub 提取教师名册()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("课程清单")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "课程清单为空！": End
    ar = .Range("a1:b" & r)
End With
ReDim br(1 To UBound(ar), 1 To 2)
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        If InStr(ar(i, 1), "|") > 0 Then
            xm = Split(ar(i, 1), "|")(0)
            t = d(xm)
            If t = "" Then
                k = k + 1
                d(xm) = k
                t = k
                br(k, 1) = k
                br(k, 2) = xm
            End If
        End If
    End If
Next i
With Sheets("教师名册")
    .[a1].CurrentRegion.Offset(1) = Empty
    .[a2].Resize(k, 2) = br
End With
MsgBox "ok!"
End Sub

3190496160

3190496160

教师名册提取.rar (67.5 KB, 下载次数: 7)

2023-3-18 10:26 上传

点击文件名下载附件

121行数据有问题