[已解决]课程表

乐乐2006201506

根据sheet3中数据，填写sheet2数据。谢谢！

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-12-20 09:50

不安*号截取的方法，另外我好像没发现合并单元格么！

1. Sub 提取数据()
   
2.     Dim r, match, arr, i As Integer, j As Integer, brr, x As Integer
   
3.     Set r = CreateObject("vbscript.regexp")
   
4.     arr = Sheet3.Range("B2:AA12")
   
5.     x = 1
   
6.     r.Pattern = "[\u4e00-\u9fa5]+\s*[\u4e00-\u9fa5]*"
   
7.     r.Global = False
   
8.     With Sheet2
   
9.         For i = 1 To UBound(arr, 2) Step 2
   
10.             For j = 2 To UBound(arr)
    
11.                 If arr(j, i) <> "" Then
    
12.                     x = x + 1
    
13.                     .Cells(x, 1) = r.Execute(arr(j, i))(0)
    
14.                     .Cells(x, 2) = arr(1, i)
    
15.                     brr = Split(arr(j, i + 1), "、")
    
16.                     .Cells(x, 3).Resize(1, UBound(brr) + 1) = brr
    
17.                 Else
    
18.                     Exit For
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End With
    
23. End Sub

复制代码

跳转到最佳答案楼层

wanao2008

请测试：
（对应名字中有*号做的，如果没有*号，可能结果会有不同）

1. Sub wanao()
   
2.     Dim arr, Str, lRow As Integer, lColumn As Integer, ke
   
3.     arr = Sheet3.Range("B2:AA12")
   
4.     With Sheet2
   
5.         lRow = .Range("A65536").End(xlUp).Row
   
6.         For y = 1 To UBound(arr, 2) Step 2
   
7.             For x = 2 To UBound(arr)
   
8.                 If arr(x, y) <> "" Then
   
9.                     lRow = lRow + 1
   
10.                     Str = Split(arr(x, y), "*")(0) & "*"
    
11.                     .Cells(lRow, 1) = Str
    
12.                     .Cells(lRow, 2) = arr(1, y)
    
13.                     ke = Split(arr(x, y + 1), "、")
    
14.                     lColumn = 2
    
15.                     For i = 0 To UBound(ke)
    
16.                         lColumn = lColumn + 1
    
17.                         .Cells(lRow, lColumn) = ke(i)
    
18.                     Next
    
19.                 Else
    
20.                     Exit For
    
21.                 End If
    
22.            Next
    
23.         Next
    
24.     End With
    
25. End Sub

复制代码

乐乐2006201506

wanao2008 发表于 2016-12-19 20:46
请测试：
（对应名字中有*号做的，如果没有*号，可能结果会有不同）

非常感谢您的及时解答，但我是用星号替换了名字中的一个字，实际上星号是具体的不同字，能否进一步处理一下，同时，只有语数外三门的老师能够全部提取，而其他科目的，因为有合并单元格，所以只提取每科第一个老师的信息。希望也能够解决。谢谢！

乐乐2006201506

烦请wanao2008老师解决合并单元格及不连续单元格数据无法提取问题，谢谢！

老司机带带我

不安*号截取的方法，另外我好像没发现合并单元格么！

1. Sub 提取数据()
   
2.     Dim r, match, arr, i As Integer, j As Integer, brr, x As Integer
   
3.     Set r = CreateObject("vbscript.regexp")
   
4.     arr = Sheet3.Range("B2:AA12")
   
5.     x = 1
   
6.     r.Pattern = "[\u4e00-\u9fa5]+\s*[\u4e00-\u9fa5]*"
   
7.     r.Global = False
   
8.     With Sheet2
   
9.         For i = 1 To UBound(arr, 2) Step 2
   
10.             For j = 2 To UBound(arr)
    
11.                 If arr(j, i) <> "" Then
    
12.                     x = x + 1
    
13.                     .Cells(x, 1) = r.Execute(arr(j, i))(0)
    
14.                     .Cells(x, 2) = arr(1, i)
    
15.                     brr = Split(arr(j, i + 1), "、")
    
16.                     .Cells(x, 3).Resize(1, UBound(brr) + 1) = brr
    
17.                 Else
    
18.                     Exit For
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End With
    
23. End Sub

复制代码

乐乐2006201506

老司机带带我 发表于 2016-12-20 09:50
不安*号截取的方法，另外我好像没发现合并单元格么！

又见到您（老司机老师）了，非常高兴，高兴之余。发现您的代码完全符合的的要求。不过能不能给两个字姓名的老师，中间加两个空格（已有空格的略过，保持原来的空格状况）？同时把班级文本形式的变为数字形式的（附件已重新上传），谢谢！

老司机带带我

乐乐2006201506 发表于 2016-12-20 11:02
又见到您（老司机老师）了，非常高兴，高兴之余。发现您的代码完全符合的的要求。不过能不能给两个字姓名 ...

转换成数值根据前面那位老师的代码多个循环就行了，空格已加！

1. Sub 提取数据X()
   
2.     Dim r, match, arr, i As Integer, j As Integer, brr, x As Integer, str$
   
3.     Set r = CreateObject("vbscript.regexp")
   
4.     arr = Sheet3.Range("B2:AA12")
   
5.     x = 1
   
6.     r.Pattern = "[\u4e00-\u9fa5]+\s*[\u4e00-\u9fa5]*"
   
7.     r.Global = False
   
8.     With Sheet2
   
9.         For i = 1 To UBound(arr, 2) Step 2
   
10.             For j = 2 To UBound(arr)
    
11.                 If arr(j, i) <> "" Then
    
12.                     x = x + 1
    
13.                     str = r.Execute(arr(j, i))(0)
    
14.                     If Len(str) = 2 Then
    
15.                         .Cells(x, 1) = Mid(str, 1, 1) & " " & Right(str, 1)
    
16.                     Else
    
17.                         .Cells(x, 1) = str
    
18.                     End If
    
19.                     .Cells(x, 2) = arr(1, i)
    
20.                     brr = Split(arr(j, i + 1), "、")
    
21.                     lColumn = 2
    
22.                     For u = 0 To UBound(brr)
    
23.                         lColumn = lColumn + 1
    
24.                         .Cells(x, lColumn) = brr(u)
    
25.                     Next
    
26.                 Else
    
27.                     Exit For
    
28.                 End If
    
29.             Next
    
30.         Next
    
31.     End With
    
32. End Sub

复制代码

雄鹰2013

老司机带带我 发表于 2016-12-20 12:35
转换成数值根据前面那位老师的代码多个循环就行了，空格已加！

老司机老师，您是颜老师吗

老司机带带我

雄鹰2013 发表于 2016-12-20 17:12
老司机老师，您是颜老师吗

{:361:}

雄鹰2013

老司机带带我 发表于 2016-12-21 08:46

颜老师，看了头像就是你啊。