如何用vba从总课表提取个人课表

gnmxzzx

自己尝试vba学习，但无法输出正确结果，麻烦大神指导！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.19
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 1).End(3).Row
   
6.         arr = .[a1].Resize(r, 26)
   
7.     End With
   
8.     On Error Resume Next
   
9.     For i = 3 To UBound(arr)
   
10.         For j = 2 To UBound(arr, 2)
    
11.             If arr(1, j) <> Empty Then st = arr(1, j)
    
12.             If arr(i, 1) = "早读" Or arr(i, 1) = "延时服务" Then
    
13.                 s = arr(i, j) & "|" & arr(i, 1) & "|" & st
    
14.                 d(s) = arr(2, j)
    
15.             Else
    
16.                 b = Split(arr(i, j), Chr(10))
    
17.                 xm = b(1): km = b(0)
    
18.                 s = xm & "|" & arr(i, 1) & "|" & st
    
19.                 d(s) = arr(2, j) & km
    
20.             End If
    
21.         Next
    
22.     Next
    
23.     With Sheets("Sheet2")
    
24.         .[b3:f12] = ""
    
25.         arr = .UsedRange
    
26.         xm = .[c1].Value
    
27.         For i = 3 To UBound(arr)
    
28.             For j = 2 To 6
    
29.                 s = xm & "|" & arr(i, 1) & "|" & arr(2, j)
    
30.                 If d.exists(s) Then
    
31.                     arr(i, j) = d(s)
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.         .UsedRange = arr
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    
41. 
    

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     With Worksheets("sheet2")
   
5.         xm = .Range("c1")
   
6.     End With
   
7.     With Worksheets("sheet1")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
   
10.         arr = .Range("a1").Resize(r, c)
    
11.     End With
    
12.     ReDim brr(1 To 10, 1 To 5)
    
13.     For j = 2 To UBound(arr, 2)
    
14.         If Len(arr(1, j)) <> 0 Then
    
15.             n = InStr("一二三四五", Right(arr(1, j), 1))
    
16.         End If
    
17.         For i = 3 To UBound(arr)
    
18.             If Len(arr(i, j)) <> 0 Then
    
19.                 xx = Split(arr(i, j), vbLf)
    
20.                 If UBound(xx) = 0 Then
    
21.                     xmm = xx(0)
    
22.                 Else
    
23.                     xmm = xx(1)
    
24.                 End If
    
25.                 If xmm = xm Then
    
26.                     If UBound(xx) = 0 Then
    
27.                         brr(i - 2, n) = arr(2, j)
    
28.                     Else
    
29.                         brr(i - 2, n) = arr(2, j) & vbLf & xx(0)
    
30.                     End If
    
31.                 End If
    
32.             End If
    
33.         Next
    
34.     Next
    
35.     With Worksheets("sheet2")
    
36.         .Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
37.     End With
    
38.         
    
39. End Sub
    

复制代码

chxw68

参与一下。

gnmxzzx

@chxw68，@ykcbf1100，非常感谢两位高手，效果绝对，正在慢慢理解吸收！

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。

Sub test()
    Dim brr
    arr = Sheet1.UsedRange
    For j = 2 To UBound(arr, 2)
        If arr(1, j) = Empty Then arr(1, j) = arr(1, j - 1)
    Next
    Set d = CreateObject("scripting.dictionary")
    With Sheet2
        s = .[c1] & "|"
        brr = .Range("a1").Resize(.Cells(.Rows.Count, 1).End(3).Row, 6)
        n = 0
        For i = 3 To UBound(brr)
            n = n + 1
            d(brr(i, 1)) = n
        Next
        n = 0
        For i = 2 To UBound(brr, 2)
            n = n + 1
            d(brr(2, i)) = n
        Next
        ReDim brr(1 To UBound(brr) - 2, 1 To UBound(brr, 2) - 1)
        For i = 3 To UBound(arr)
            For j = 2 To UBound(arr, 2)
                If InStr(arr(i, j) & "|", s) Then
                    brr(d(arr(i, 1)), d(arr(1, j))) = arr(2, j)
                End If
            Next
        Next
        .Range("a1").Offset(2, 1).Resize(.Cells(.Rows.Count, 1).End(3).Row - 2, 5) = brr
    End With
    Set d = Nothing
    Beep
End Sub

gnmxzzx

quqiyuan 发表于 2024-9-19 17:56
代码如下。。。

Sub test()

感谢大佬，但正课没显示科目，数组复杂，正在慢慢消化吸收。

quqiyuan

gnmxzzx 发表于 2024-9-19 18:56
感谢大佬，但正课没显示科目，数组复杂，正在慢慢消化吸收。

哦，没有注意你还要写科目，不难，稍作改动，仅供参考。。。