[已解决]请问怎样修改代码

dyzx

请老师帮帮助，如果将表1转换成表2应怎样修改里面的代码，多谢指教，多谢

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2015-1-31 21:56

dyzx 发表于 2015-1-30 08:35
hwc2ycy老师：非常多谢你的耐心指教，就是除了“**长、主任、书记”等外，其它就是“教师”职务，多谢[/b ...

1. Sub 转换()
   
2.     Dim r%, i%, m%, j%
   
3.     Dim arr, brr(1 To 1000, 1 To 6)
   
4.     Dim arrT1, arrT2
   
5.     Dim str1$, str2$, str3$ ', str4$
   
6.     Dim reg As Object, mh As Object
   
7.     'Dim reg As RegExp
   
8.     Dim strKm$, strNj$, strBj$, strZw$
   
9. 
   
10.     str1 = "(初一|初二|初三)(.*?)(语文|数学|英语|政治|历史|音乐|化学|物理|地理|信息技术|生物|体育|美术|综合实践|写字课)"
    
11. 
    
12.     '职务
    
13.     str2 = "[^\s}]+?(长|任|记)"
    
14. 
    
15.     '去多余的空格
    
16.     str3 = "\s+"
    
17. 
    
18.     Application.ScreenUpdating = False
    
19.     Set reg = CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
    
20.     reg.Global = True
    
21. 
    
22.     m = 0
    
23.     With Worksheets("表1")
    
24.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
25.         arr = .Range("a3:l" & r)
    
26.     End With
    
27. 
    
28.     'brr: 序号 姓名 职务 任教科目 任教年级 任教班级
    
29.     For j = 1 To UBound(arr, 2) Step 3
    
30.         For i = 1 To UBound(arr)
    
31.             If Len(arr(i, j + 1)) <> 0 Then
    
32.                 strKm = "": strNj = "": strBj = "": strZw = ""
    
33.                 reg.Pattern = str3
    
34.                 arrT2 = Split(reg.Replace(arr(i, j + 2), " "))
    
35.                 m = m + 1
    
36.                 brr(m, 1) = m   '序号
    
37.                 brr(m, 2) = arr(i, j + 1)   '姓名
    
38.                 For Each arrT1 In arrT2
    
39.                     With reg
    
40.                         '职务
    
41.                         .Pattern = str2
    
42.                         If .Test(arrT1) Then
    
43.                             Set mh = .Execute(arrT1)
    
44.                             strZw = strZw & mh(0) & "/"
    
45.                         Else
    
46.                             '班级，科目
    
47.                             .Pattern = str1
    
48.                             If .Test(arrT1) Then
    
49.                                 Set mh = .Execute(arrT1)
    
50.                                 If InStr(1, strKm, mh(0).SubMatches(2), vbBinaryCompare) = 0 Then strKm = strKm & mh(0).SubMatches(2) & "，"
    
51.                                 'brr(m, 4) = brr(m, 4) & mh(0).SubMatches(2) & "，"
    
52.                                 If InStr(1, strNj, mh(0).SubMatches(0), vbBinaryCompare) = 0 Then strNj = strNj & mh(0).SubMatches(0) & "，"
    
53.                                 'brr(m, 5) = brr(m, 5) & mh(0).SubMatches(0) & "，"
    
54.                                 If mh(0).SubMatches(1) <> "级" Then
    
55.                                     If InStr(1, strBj, mh(0).SubMatches(1), vbBinaryCompare) = 0 Then strBj = strBj & mh(0).SubMatches(1) & "，"
    
56.                                     'brr(m, 6) = brr(m, 6) & mh(0).SubMatches(1) & "，"
    
57.                                 Else
    
58.                                     If InStr(1, strBj, "全级", vbBinaryCompare) = 0 Then strBj = strBj & "全级，"
    
59.                                 End If
    
60.                             End If
    
61.                         End If
    
62.                     End With
    
63.                 Next
    
64.                 If Len(strZw) Then
    
65.                     brr(m, 3) = Left(strZw, Len(strZw) - 1)
    
66.                 Else
    
67.                     brr(m, 3) = "教师"
    
68.                 End If
    
69.                
    
70.                 If Len(strKm) Then brr(m, 4) = Left(strKm, Len(strKm) - 1)
    
71.                 If Len(strNj) Then brr(m, 5) = Left(strNj, Len(strNj) - 1)
    
72.                 If Len(strBj) Then brr(m, 6) = Left(strBj, Len(strBj) - 1)
    
73. 
    
74.             End If
    
75.         Next
    
76.     Next
    
77.     With Worksheets("表2")
    
78.         With .Range("a3").Resize(UBound(brr), UBound(brr, 2))
    
79.             .Value = brr
    
80.             .Borders.LineStyle = xlContinuous
    
81.             .Font.Size = 10
    
82.             .HorizontalAlignment = xlCenter
    
83.             .VerticalAlignment = xlCenter
    
84.         End With
    
85.     End With
    
86.     Application.ScreenUpdating = True
    
87.     MsgBox "转换完成", vbInformation + vbOKOnly, "提示"
    
88. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

做个记号，规则应用还是比较复杂的，明天再抽时间看。

dyzx

hwc2ycy 发表于 2015-1-28 23:02
做个记号，规则应用还是比较复杂的，明天再抽时间看。

hwc2ycy老师：先多谢你的指教，多谢

hwc2ycy

1. Sub 转换()
   
2.     Dim r%, i%, m%, j%
   
3.     Dim arr, brr(1 To 1000, 1 To 6)
   
4.     Dim arrT1, arrT2
   
5.     Dim str1$, str2$, str3$ ', str4$
   
6.     Dim reg As Object, mh As Object
   
7.     'Dim reg As RegExp
   
8.     Dim strKm$, strNj$, strBj$, strZw$
   
9. 
   
10.     str1 = "(初一|初二|初三)(.*?)(语文|数学|英语|政治|历史|音乐|化学|物理|地理|信息技术|生物|体育|美术|综合实践|写字课)"
    
11. 
    
12.     '职务
    
13.     str2 = "[^\s}]+?(长|任|干部|记)"
    
14. 
    
15.     '去多余的空格
    
16.     str3 = "\s+"
    
17. 
    
18.     Application.ScreenUpdating = False
    
19.     Set reg = CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
    
20.     reg.Global = True
    
21. 
    
22.     m = 0
    
23.     With Worksheets("表1")
    
24.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
25.         arr = .Range("a3:l" & r)
    
26.     End With
    
27. 
    
28.     'brr: 序号 姓名 职务 任教科目 任教年级 任教班级
    
29.     For j = 1 To UBound(arr, 2) Step 3
    
30.         For i = 1 To UBound(arr)
    
31.             If Len(arr(i, j + 1)) <> 0 Then
    
32.                 strKm = "": strNj = "": strBj = "": strZw = ""
    
33.                 reg.Pattern = str3
    
34.                 arrT2 = Split(reg.Replace(arr(i, j + 2), " "))
    
35.                 m = m + 1
    
36.                 brr(m, 1) = m   '序号
    
37.                 brr(m, 2) = arr(i, j + 1)   '姓名
    
38.                 For Each arrT1 In arrT2
    
39.                     With reg
    
40.                         '职务
    
41.                         .Pattern = str2
    
42.                         If .Test(arrT1) Then
    
43.                             Set mh = .Execute(arrT1)
    
44.                             strZw = strZw & mh(0) & "/"
    
45.                         Else
    
46.                             '班级，科目
    
47.                             .Pattern = str1
    
48.                             If .Test(arrT1) Then
    
49.                                 Set mh = .Execute(arrT1)
    
50.                                 If InStr(1, strKm, mh(0).SubMatches(2), vbBinaryCompare) = 0 Then strKm = strKm & mh(0).SubMatches(2) & "，"
    
51.                                 'brr(m, 4) = brr(m, 4) & mh(0).SubMatches(2) & "，"
    
52.                                 If InStr(1, strNj, mh(0).SubMatches(0), vbBinaryCompare) = 0 Then strNj = strNj & mh(0).SubMatches(0) & "，"
    
53.                                 'brr(m, 5) = brr(m, 5) & mh(0).SubMatches(0) & "，"
    
54.                                 If mh(0).SubMatches(1) <> "级" Then
    
55.                                     If InStr(1, strBj, mh(0).SubMatches(1), vbBinaryCompare) = 0 Then strBj = strBj & mh(0).SubMatches(1) & "，"
    
56.                                     'brr(m, 6) = brr(m, 6) & mh(0).SubMatches(1) & "，"
    
57.                                 Else
    
58.                                     If InStr(1, strBj, "全级", vbBinaryCompare) = 0 Then strBj = strBj & "全级，"
    
59.                                 End If
    
60.                             End If
    
61.                         End If
    
62.                     End With
    
63.                 Next
    
64.                 If Len(strZw) Then brr(m, 3) = Left(strZw, Len(strZw) - 1)
    
65.                 If Len(strKm) Then brr(m, 4) = Left(strKm, Len(strKm) - 1)
    
66.                 If Len(strNj) Then brr(m, 5) = Left(strNj, Len(strNj) - 1)
    
67.                 If Len(strBj) Then brr(m, 6) = Left(strBj, Len(strBj) - 1)
    
68. 
    
69.             End If
    
70.         Next
    
71.     Next
    
72.     With Worksheets("表2")
    
73.         With .Range("a3").Resize(UBound(brr), UBound(brr, 2))
    
74.             .Value = brr
    
75.             .Borders.LineStyle = xlContinuous
    
76.             .Font.Size = 10
    
77.             .HorizontalAlignment = xlCenter
    
78.             .VerticalAlignment = xlCenter
    
79.         End With
    
80.     End With
    
81.     Application.ScreenUpdating = True
    
82.     MsgBox "转换完成", vbInformation + vbOKOnly, "提示"
    
83. End Sub
    

复制代码

dyzx

hwc2ycy 发表于 2015-1-29 15:54

hwc2ycy老师：非常多谢你的帮助，但还有一个小小要求，就是职务一栏除了“**长”之外，其余就是“教师”，那代码应该怎样修改，多谢指教，多谢

hwc2ycy

dyzx 发表于 2015-1-29 17:16
hwc2ycy老师：非常多谢你的帮助，但还有一个小小要求，就是职务一栏除了“**长”之外，其余就 ...

意思就是职务就两种 XX长和老师，像主任，书记，也不用么

dyzx

hwc2ycy 发表于 2015-1-29 21:50
意思就是职务就两种 XX长和老师，像主任，书记，也不用么

hwc2ycy老师：非常多谢你的耐心指教，就是除了“**长、主任、书记”等外，其它就是“教师”职务，多谢

hwc2ycy

dyzx 发表于 2015-1-30 08:35
hwc2ycy老师：非常多谢你的耐心指教，就是除了“**长、主任、书记”等外，其它就是“教师”职务，多谢[/b ...

1. Sub 转换()
   
2.     Dim r%, i%, m%, j%
   
3.     Dim arr, brr(1 To 1000, 1 To 6)
   
4.     Dim arrT1, arrT2
   
5.     Dim str1$, str2$, str3$ ', str4$
   
6.     Dim reg As Object, mh As Object
   
7.     'Dim reg As RegExp
   
8.     Dim strKm$, strNj$, strBj$, strZw$
   
9. 
   
10.     str1 = "(初一|初二|初三)(.*?)(语文|数学|英语|政治|历史|音乐|化学|物理|地理|信息技术|生物|体育|美术|综合实践|写字课)"
    
11. 
    
12.     '职务
    
13.     str2 = "[^\s}]+?(长|任|记)"
    
14. 
    
15.     '去多余的空格
    
16.     str3 = "\s+"
    
17. 
    
18.     Application.ScreenUpdating = False
    
19.     Set reg = CreateObject("VBSCRIPT.REGEXP")  '引用正则表达式
    
20.     reg.Global = True
    
21. 
    
22.     m = 0
    
23.     With Worksheets("表1")
    
24.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
25.         arr = .Range("a3:l" & r)
    
26.     End With
    
27. 
    
28.     'brr: 序号 姓名 职务 任教科目 任教年级 任教班级
    
29.     For j = 1 To UBound(arr, 2) Step 3
    
30.         For i = 1 To UBound(arr)
    
31.             If Len(arr(i, j + 1)) <> 0 Then
    
32.                 strKm = "": strNj = "": strBj = "": strZw = ""
    
33.                 reg.Pattern = str3
    
34.                 arrT2 = Split(reg.Replace(arr(i, j + 2), " "))
    
35.                 m = m + 1
    
36.                 brr(m, 1) = m   '序号
    
37.                 brr(m, 2) = arr(i, j + 1)   '姓名
    
38.                 For Each arrT1 In arrT2
    
39.                     With reg
    
40.                         '职务
    
41.                         .Pattern = str2
    
42.                         If .Test(arrT1) Then
    
43.                             Set mh = .Execute(arrT1)
    
44.                             strZw = strZw & mh(0) & "/"
    
45.                         Else
    
46.                             '班级，科目
    
47.                             .Pattern = str1
    
48.                             If .Test(arrT1) Then
    
49.                                 Set mh = .Execute(arrT1)
    
50.                                 If InStr(1, strKm, mh(0).SubMatches(2), vbBinaryCompare) = 0 Then strKm = strKm & mh(0).SubMatches(2) & "，"
    
51.                                 'brr(m, 4) = brr(m, 4) & mh(0).SubMatches(2) & "，"
    
52.                                 If InStr(1, strNj, mh(0).SubMatches(0), vbBinaryCompare) = 0 Then strNj = strNj & mh(0).SubMatches(0) & "，"
    
53.                                 'brr(m, 5) = brr(m, 5) & mh(0).SubMatches(0) & "，"
    
54.                                 If mh(0).SubMatches(1) <> "级" Then
    
55.                                     If InStr(1, strBj, mh(0).SubMatches(1), vbBinaryCompare) = 0 Then strBj = strBj & mh(0).SubMatches(1) & "，"
    
56.                                     'brr(m, 6) = brr(m, 6) & mh(0).SubMatches(1) & "，"
    
57.                                 Else
    
58.                                     If InStr(1, strBj, "全级", vbBinaryCompare) = 0 Then strBj = strBj & "全级，"
    
59.                                 End If
    
60.                             End If
    
61.                         End If
    
62.                     End With
    
63.                 Next
    
64.                 If Len(strZw) Then
    
65.                     brr(m, 3) = Left(strZw, Len(strZw) - 1)
    
66.                 Else
    
67.                     brr(m, 3) = "教师"
    
68.                 End If
    
69.                
    
70.                 If Len(strKm) Then brr(m, 4) = Left(strKm, Len(strKm) - 1)
    
71.                 If Len(strNj) Then brr(m, 5) = Left(strNj, Len(strNj) - 1)
    
72.                 If Len(strBj) Then brr(m, 6) = Left(strBj, Len(strBj) - 1)
    
73. 
    
74.             End If
    
75.         Next
    
76.     Next
    
77.     With Worksheets("表2")
    
78.         With .Range("a3").Resize(UBound(brr), UBound(brr, 2))
    
79.             .Value = brr
    
80.             .Borders.LineStyle = xlContinuous
    
81.             .Font.Size = 10
    
82.             .HorizontalAlignment = xlCenter
    
83.             .VerticalAlignment = xlCenter
    
84.         End With
    
85.     End With
    
86.     Application.ScreenUpdating = True
    
87.     MsgBox "转换完成", vbInformation + vbOKOnly, "提示"
    
88. End Sub

复制代码

dyzx

hwc2ycy教师：非常多谢你的帮助，辛苦你了，多谢