[已解决]关于关键字提取的问题

xzwdk

我想在K28单元格内输入信息，然后将内容的各关键字分解到指定的单元格内。目前我用函数已经实现了结果，由于此部分为我的表格的一项内容，但是由于函数公式较复杂，所以运行比较慢，希望各位老师根据我目前的运算函数，帮我用VBA实现以上功能（需要维持表格的目前框架）。鉴于K28中的输入内容比较丰富，特别是“-”前的位数可能为4位数也可能是5位数，字符“-”后面可能是2位数字或3位数字加字母，字符“DN”后面可能是2位数字、3位数字或者4位数字，同时，输入内容还需要保留一定数量的空格，见举例。所以上面的函数判断条件比较多。辛苦各位老师了。谢谢。

最佳答案

月排行榜 / 总排行榜

redsheep

2013-8-28 10:24

给你做了一个试试吧
分解关键字.zip (15.39 KB, 下载次数: 37)

2013-8-28 10:57 上传

点击文件名下载附件

有些要求可能不太对的话你自己改改   因为你也不用文字解释一下每个参数的意义  就靠分析你原来的公式   这是一件十分消耗精力的事情!!!

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Address <> "$K$28" Then Exit Sub
   
3. 
   
4. On Error Resume Next '忽略错误
   
5. Dim Char(5), KyWrd(10)
   
6. Dim Txt, A, B, C, D, i, m, q
   
7. 
   
8. Txt = Replace(Sheet1.[k28].Value, "-", " ")
   
9. 
   
10. '将原数据按照分隔符分成5部分
    
11. D = 1
    
12. For i = 1 To Len(Txt)
    
13.     If Mid(Txt, i, 1) <> " " Then
    
14.         Char(D) = Char(D) & Mid(Txt, i, 1)
    
15.     Else
    
16.         D = D + 1
    
17.     End If
    
18. Next
    
19. 
    
20. '取前2个关键字
    
21. A = Len(Char(1))
    
22. If IsNumeric(Mid(Char(1), 2, 1)) Then '判断第二个字符是不是数字
    
23.     KyWrd(1) = Left(Char(1), 1)
    
24.     If A = 5 Then KyWrd(2) = Mid(Char(1), 2, 1)
    
25. Else
    
26.     KyWrd(1) = Left(Char(1), 2)
    
27. End If
    
28. 
    
29. '取第3-5个关键字
    
30. KyWrd(3) = Mid(Char(1), A - 2, 1)
    
31. KyWrd(4) = Mid(Char(1), A - 1, 1)
    
32. KyWrd(5) = Mid(Char(1), A - 0, 1)
    
33. 
    
34. 
    
35. '取第6-7个关键字
    
36. B = Len(Char(2))
    
37. If IsNumeric(Right(Char(2), 1)) Then '判断压力等级最后的字符是不是数字
    
38.     KyWrd(6) = Char(2)
    
39. Else
    
40.     KyWrd(6) = Left(Char(2), B - 1)
    
41.     KyWrd(7) = Right(Char(2), 1)
    
42. End If
    
43. 
    
44. 
    
45. '取第8-10个关键字
    
46. KyWrd(8) = Char(3)
    
47. KyWrd(9) = Char(4)
    
48. KyWrd(10) = Char(5)
    
49. 
    
50. '把关键字传递到表格
    
51. For q = 1 To 10
    
52.     Sheet1.Cells(q * 2 + 3, 12).Value = KyWrd(q) '测试的时候中间那个 12 是把结果写道了L列  如果你测试完觉得没问题,就改成 11
    
53. Next
    
54. 
    
55. End Sub
    

复制代码

跳转到最佳答案楼层

1411123034

路过

xhrys

不会 貌似可以用split  

w2001pf

你应该把你涉及问题的各举一个例子，那样便于别人理解后再帮助你的。

xzwdk

w2001pf 发表于 2013-8-28 09:30
你应该把你涉及问题的各举一个例子，那样便于别人理解后再帮助你的。

我的VB基础比较薄，目前不知道如何用VBA实现以上功能。还请给以指导，谢谢！

redsheep

给你做了一个试试吧
分解关键字.zip (15.39 KB, 下载次数: 37)

2013-8-28 10:57 上传

点击文件名下载附件

有些要求可能不太对的话你自己改改   因为你也不用文字解释一下每个参数的意义  就靠分析你原来的公式   这是一件十分消耗精力的事情!!!

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Address <> "$K$28" Then Exit Sub
   
3. 
   
4. On Error Resume Next '忽略错误
   
5. Dim Char(5), KyWrd(10)
   
6. Dim Txt, A, B, C, D, i, m, q
   
7. 
   
8. Txt = Replace(Sheet1.[k28].Value, "-", " ")
   
9. 
   
10. '将原数据按照分隔符分成5部分
    
11. D = 1
    
12. For i = 1 To Len(Txt)
    
13.     If Mid(Txt, i, 1) <> " " Then
    
14.         Char(D) = Char(D) & Mid(Txt, i, 1)
    
15.     Else
    
16.         D = D + 1
    
17.     End If
    
18. Next
    
19. 
    
20. '取前2个关键字
    
21. A = Len(Char(1))
    
22. If IsNumeric(Mid(Char(1), 2, 1)) Then '判断第二个字符是不是数字
    
23.     KyWrd(1) = Left(Char(1), 1)
    
24.     If A = 5 Then KyWrd(2) = Mid(Char(1), 2, 1)
    
25. Else
    
26.     KyWrd(1) = Left(Char(1), 2)
    
27. End If
    
28. 
    
29. '取第3-5个关键字
    
30. KyWrd(3) = Mid(Char(1), A - 2, 1)
    
31. KyWrd(4) = Mid(Char(1), A - 1, 1)
    
32. KyWrd(5) = Mid(Char(1), A - 0, 1)
    
33. 
    
34. 
    
35. '取第6-7个关键字
    
36. B = Len(Char(2))
    
37. If IsNumeric(Right(Char(2), 1)) Then '判断压力等级最后的字符是不是数字
    
38.     KyWrd(6) = Char(2)
    
39. Else
    
40.     KyWrd(6) = Left(Char(2), B - 1)
    
41.     KyWrd(7) = Right(Char(2), 1)
    
42. End If
    
43. 
    
44. 
    
45. '取第8-10个关键字
    
46. KyWrd(8) = Char(3)
    
47. KyWrd(9) = Char(4)
    
48. KyWrd(10) = Char(5)
    
49. 
    
50. '把关键字传递到表格
    
51. For q = 1 To 10
    
52.     Sheet1.Cells(q * 2 + 3, 12).Value = KyWrd(q) '测试的时候中间那个 12 是把结果写道了L列  如果你测试完觉得没问题,就改成 11
    
53. Next
    
54. 
    
55. End Sub
    

复制代码

xzwdk

redsheep 发表于 2013-8-28 10:24
给你做了一个试试吧

谢谢老师的支持。我修改了一部分内容后，虽然已经实现我的要求了，还请老师看看还有没有需要优化的地方？

'取第8-10个关键字
KyWrd(8) = Char(3)
If InStr(1, Char(4), "Ex") Or InStr(1, Char(4), "EX") Or InStr(1, Char(4), "ex") Then
  KyWrd(9) = Char(4)
  If KyWrd(2) = 6 Then KyWrd(10) = Char(5)
Else
  If KyWrd(2) = 6 Then KyWrd(10) = Char(4)
End If

redsheep

xzwdk 发表于 2013-8-28 14:21
谢谢老师的支持。我修改了一部分内容后，虽然已经实现我的要求了，还请老师看看还有没有需要优化的地方？ ...

原来最后几个也有要求   当时没看明白

是不是第2个得有数字  并且含"ex"字符的才是关键词9?
是不是第2个是6,且含"作用"字符的才是关键词10?
你原来的公式真的让人头大啊   谁能根据你那个公式把每条定义都看全了啊

刚刚研究了一下like这个功能  判断条件简化了一下    增加了上面说的功能

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Address <> "$K$28" Then Exit Sub
   
3. On Error Resume Next '忽略错误
   
4. Dim Char(5), KyWrd(10)
   
5. Dim Txt, A, B, C, D, i, m, q
   
6. 
   
7. Txt = Replace(Sheet1.[k28].Value, "-", " ")
   
8. 
   
9. '将原数据按照分隔符分成5部分
   
10. D = 1
    
11. For i = 1 To Len(Txt)
    
12.     If Mid(Txt, i, 1) <> " " Then
    
13.         Char(D) = Char(D) & Mid(Txt, i, 1)
    
14.     Else
    
15.         D = D + 1
    
16.     End If
    
17. Next
    
18. 
    
19. '取前2个关键字
    
20. A = Len(Char(1))
    
21. If Char(1) Like "?[0-9]*" Then '判断第二个字符是不是数字
    
22.     KyWrd(1) = Left(Char(1), 1)
    
23.     If A = 5 Then KyWrd(2) = Mid(Char(1), 2, 1)
    
24. Else
    
25.     KyWrd(1) = Left(Char(1), 2)
    
26. End If
    
27. 
    
28. '取第3-5个关键字
    
29. KyWrd(3) = Mid(Char(1), A - 2, 1)
    
30. KyWrd(4) = Mid(Char(1), A - 1, 1)
    
31. KyWrd(5) = Mid(Char(1), A - 0, 1)
    
32. 
    
33. 
    
34. '取第6-7个关键字
    
35. If Char(2) Like "*[0-9]" Then '判断压力等级最后的字符是不是数字
    
36.     KyWrd(6) = Char(2)
    
37. Else
    
38.     KyWrd(6) = Left(Char(2), Len(Char(2)) - 1)
    
39.     KyWrd(7) = Right(Char(2), 1)
    
40. End If
    
41. 
    
42. 
    
43. '取第8关键字
    
44. KyWrd(8) = Char(3)
    
45. 
    
46. '取第9关键字
    
47. If UCase(Char(4)) Like "EX*" And KyWrd(2) <> "" Then KyWrd(9) = Char(4)
    
48. 
    
49. '取第10关键字
    
50. If KyWrd(2) = 6 Then
    
51.     If Char(4) Like "*作用*" Then KyWrd(10) = Char(4)
    
52.     If Char(5) Like "*作用*" Then KyWrd(10) = Char(5)
    
53. End If
    
54. 
    
55. '把关键字传递到表格
    
56. For q = 1 To 10
    
57.     Sheet1.Cells(q * 2 + 3, 12).Value = KyWrd(q) '测试的时候中间那个 12 是把结果写道了L列  如果你测试完觉得没问题,就改成 11
    
58. Next
    
59. 
    
60. End Sub
    

复制代码

xzwdk

redsheep 发表于 2013-8-28 22:24
原来最后几个也有要求   当时没看明白

是不是第2个得有数字  并且含"ex"字符的才是关键词9?

非常感谢。赞一个，收下了。