求助，能否将表一的信息提取到表二

fangfhf

求助：能否根据表二的姓名，将这个姓名在表一的信息提取到表二中？

ykcbf1100

没看明白啊。
表2中的号码哪里来的？表2中的字段，有好多班级和课程，与表1是什么对应关系？

fangfhf

ykcbf1100 发表于 2024-8-25 08:30
没看明白啊。
表2中的号码哪里来的？表2中的字段，有好多班级和课程，与表1是什么对应关系？

只要和表二中的名字对应就可以了，序号不用管的。表二中的名字，在表一中担任不同班级的不同课程，所以不一样

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.25
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("班级数据表")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 36)
   
7.     End With
   
8.     For j = 3 To UBound(arr, 2) Step 2
   
9.         For i = 3 To UBound(arr)
   
10.             s = arr(i, j)
    
11.             If Not d.exists(s) Then
    
12.                 d(s) = Array(arr(i, 1), arr(2, j), arr(i, j + 1))
    
13.             Else
    
14.                 t = d(s)
    
15.                 t(0) = t(0) & "#" & arr(i, 1)
    
16.                 t(1) = t(1) & "#" & arr(2, j)
    
17.                 t(2) = t(2) & "#" & arr(i, j + 1)
    
18.                 d(s) = t
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     On Error Resume Next
    
23.     With Sheets("Sheet1")
    
24.         r = .Cells(Rows.Count, 1).End(3).Row
    
25.         .UsedRange.Offset(1, 3) = ""
    
26.         For i = 2 To r
    
27.             s = .Cells(i, 2).Value
    
28.             n = 3
    
29.             If d.exists(s) Then
    
30.                 t = d(s)
    
31.                 For x = 0 To 2
    
32.                     n = n + 3
    
33.                     .Cells(i, n - 2) = Split(t(0), "#")(x)
    
34.                     .Cells(i, n - 1) = Split(t(1), "#")(x)
    
35.                     .Cells(i, n) = Split(t(2), "#")(x)
    
36.                 Next
    
37.             End If
    
38.         Next
    
39.     End With
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

zxsea_7426

练练手，好久没写了

Sub 课程汇总()
    Set d = CreateObject("scripting.dictionary")
    With Sheets("班级数据表")
        ar = .Cells(1, 1).CurrentRegion
        For i = 3 To UBound(ar)
            For j = 3 To UBound(ar, 2) Step 2
'                xm = ar(i, j)
                If ar(i, j) <> "" And ar(i, j) <> "/" Then
                    If Not d.exists(ar(i, j)) Then Set d(ar(i, j)) = CreateObject("scripting.dictionary")
                    n = d(ar(i, j)).Count + 1
                    班级 = Trim(ar(i, 1))
                    课程 = ar(2, j)
                    课时 = ar(i, j + 1)
                    d(ar(i, j))(n) = Array(班级, 课程, 课时)
                    If n > m Then
                        m = n
'                        br = d(ar(i, j))(m)
                    End If
                End If
            Next j
        Next i
    End With
    With Sheets("sheet2")
        la_ro = .Cells(Rows.Count, 2).End(3).Row
        ar = .Cells(1, 1).Resize(la_ro, m * 3 + 3)
        For j = 4 To m * 3 + 1 Step 3
            If ar(1, j) = "" Then
                ar(1, j) = "班级"
                ar(1, j + 1) = "课程"
                ar(1, j + 2) = "课时"
            End If
        Next j
        For i = 2 To UBound(ar)
            If d.exists(ar(i, 2)) Then
                n = d(ar(i, 2)).Count
                For j = 1 To n
                    ar(i, (j * 3 + 1)) = d(ar(i, 2))(j)(0)
                    ar(i, (j * 3 + 2)) = d(ar(i, 2))(j)(1)
                    ar(i, (j * 3 + 3)) = d(ar(i, 2))(j)(2)
                Next j
            End If
        Next i
        With .Cells(1, 1).Resize(la_ro, m * 3 + 3)
            .Value = ar
            .Borders.LineStyle = 1
        End With
    End With
End Sub

fangfhf

ykcbf1100 发表于 2024-8-25 09:12
参与一下。。。

太感谢了！

3190496160

Sub 数据整理()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("班级数据表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 3 Or y < 3 Then MsgBox "班级数据表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y + 1))
End With
For i = 3 To UBound(ar)
    For j = 3 To UBound(ar, 2) - 1 Step 2
        If ar(i, j) <> "" Then
            If ar(i, j) <> "/" Then
                If d(ar(i, j)) = "" Then
                    d(ar(i, j)) = ar(i, 1) & "|" & ar(2, j) & "|" & ar(i, j + 1)
                Else
                     d(ar(i, j)) = d(ar(i, j)) & ";" & ar(i, 1) & "|" & ar(2, j) & "|" & ar(i, j + 1)
                End If
            End If
        End If
    Next j
Next i
ReDim br(1 To d.Count + 1, 1 To 330)
lh = 0
n = 1
br(n, 1) = "序号"
br(n, 2) = "姓名"
br(n, 3) = "号码"
For Each k In d.keys
    n = n + 1
    br(n, 1) = n
    br(n, 2) = k
    zf = d(k)
    rr = Split(zf, ";")
    x = 3
    For i = 0 To UBound(rr)
        zd = rr(i)
        mr = Split(zd, "|")
        For s = 0 To UBound(mr)
            x = x + 1
            br(n, x) = mr(s)
        Next s
    Next i
    If x > lh Then
        lh = x
    Else
        lh = lh
    End If
Next k
rr = Array("班级", "课程", "课时")
For j = 4 To lh - 2 Step 3
    w = j - 1
    For s = 0 To UBound(rr)
        w = w + 1
        br(1, w) = rr(s)
    Next s
Next j
With Sheets("sheet1")
    .UsedRange.Borders.LineStyle = 0
    .UsedRange.ClearContents
    .[a1].Resize(n, lh) = br
    .[a1].Resize(n, lh).Borders.LineStyle = 1
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

灵活通用
能否将表一的信息，提取成表二的信息？.rar (23.91 KB, 下载次数: 6)

2024-8-25 10:32 上传

点击文件名下载附件

chxw68

参与一下。