将WORD按要求整理为excel文件，超复杂、谢谢！

lcywjr

复杂，太复杂

yangyangzhifeng

凑一个

1. Sub yang()
   
2.     Dim ar, fsdoc, i&, j&, r&, c&, reg, st$, ss$, d, br(), n&
   
3.     Set reg = CreateObject("vbscript.regexp"): Set d = CreateObject("scripting.dictionary")
   
4.     ar = Sheets("excel").[e1:q1]
   
5.     For i = 1 To UBound(ar, 2)
   
6.         d(ar(1, i)) = i + 4
   
7.     Next
   
8.     ReDim br(1 To 1000, 1 To i + 3)
   
9.     With reg
   
10.         .Global = True
    
11.         .Pattern = "^【[\u4e00-\u9fa5]+】"
    
12.     End With
    
13.     Set fsdoc = GetObject(ThisWorkbook.Path & "\中国药典2010年版一部修订1.doc")
    
14.     st = Trim(fsdoc.Range.Text)
    
15.     ar = Split(st, Chr(13))
    
16.     fsdoc.Close: st = ""
    
17.     For i = 0 To UBound(ar)
    
18.         st = Trim(ar(i))
    
19.         If st <> "" Then r = i: Exit For
    
20.     Next
    
21.     For i = r To UBound(ar)
    
22.         c = 4: n = n + 1
    
23.         For j = 0 To 3
    
24.             If ar(i + j) Like "【*" Then
    
25.                 Exit For
    
26.             End If
    
27.             br(n, j + 1) = ar(i + j)
    
28.         Next
    
29.         i = i + j
    
30.         Do
    
31.             st = Trim(ar(i))
    
32.             If reg.test(st) Then
    
33.                 ss = reg.Execute(st)(0)
    
34.                 If d.exists(ss) Then
    
35.                     If d(ss) > c Then c = d(ss)
    
36.                 End If
    
37.             End If
    
38.             br(n, c) = br(n, c) & st
    
39.             If (ss = "【贮藏】" And Not ar(i + 1) Like "【*") Or ss = "【制剂】" Then Exit Do
    
40.             i = i + 1
    
41.         Loop
    
42.         If i > UBound(ar) - 3 Then Exit For
    
43.     Next
    
44.     Application.ScreenUpdating = False
    
45.     With Sheets("EXCEL")
    
46.         .Rows("2:65536").ClearContents
    
47.         For i = 1 To n
    
48.             For j = 1 To UBound(br, 2)
    
49.                 .Cells(i + 1, j) = br(i, j)
    
50.             Next
    
51.         Next
    
52.     End With
    
53.     Application.ScreenUpdating = True
    
54. End Sub
    

复制代码

ak47ok

学习了，20楼版主的代码求出的结果排列完美一些、22楼 yangyangzhifeng大侠的代码容错能力更强一些。
感谢KCFONG 版主、yangyangzhifeng大侠。
迟点上个完整的从《中国药典》复制的药材和饮片大全试试。

再次感谢。以我的水平只有感谢的份！

ak47ok

还真是搞不定。今天整理了《中国药典》2010版一部中的640多个药材的全文，用20楼KCFONG 版主的代码只能排列完美求出44个结果，到“小茴香”就结束了，不知为何？用22楼 yangyangzhifeng大侠的代码能排列完毕，但排列的结果还需调整。

不好意思再麻烦KCFONG 版主看看如何解决。再次感谢！

上个完整版的附件。

ak47ok

KCFONG 发表于 2013-6-9 00:06
see if help you
please test

今天试了刚整理的全部药材、还是遇到问题：
24楼的附件不能整理完毕。

KCFONG

see if fit your request
Please note that each cell can only have 256 characters

ak47ok

KCFONG 发表于 2013-6-12 15:43
see if fit your request
Please note that each cell can only have 256 characters

感动、感激！再次感谢KCFONG 版主！
看来从经OCR的PDF复制的文字还要认真整理（当然是要用VBA。不然太烦、工作量太大了）
我认真学习、消化！
谢谢！

yangyangzhifeng

试试这个

1. Sub test()
   
2.     Dim ar, fsdoc, i&, j&, r&, c&, reg, st$, ss$, d, br(), n&, a&, py&, ggg
   
3.     Dim x&, y&, z&
   
4.     '    On Error Resume Next
   
5.     Set reg = CreateObject("vbscript.regexp"): Set d = CreateObject("scripting.dictionary")
   
6.     Set ggg = CreateObject("vbscript.regexp"): ggg.Global = True: ggg.IgnoreCase = True: ggg.Pattern = "^[A-Z ]+"
   
7.     ar = Sheets("excel").[d1:q1]
   
8.     For i = 1 To UBound(ar, 2)
   
9.         d(ar(1, i)) = i + 3
   
10.     Next
    
11.     d("【禁忌】") = d("【注意】"): d("本品") = 4
    
12.     ReDim br(1 To 1000, 1 To i + 2)
    
13.     With reg
    
14.         .Global = True
    
15.         .IgnoreCase = True
    
16.     End With
    
17.     Set fsdoc = GetObject(ThisWorkbook.Path & "\中华人民共和国药典药材.doc")
    
18.     st = Trim(fsdoc.Range.Text)
    
19.     ar = Split(st, Chr(13))
    
20.     fsdoc.Close: st = ""
    
21.     For i = 0 To UBound(ar)
    
22.         n = n + 1: reg.Pattern = "^[A-Z ]+$"
    
23.         a = IIf(i + 100 > UBound(ar), UBound(ar), i + 100)
    
24.         x = 0: y = 0: z = 0: py = 0
    
25.         For j = a To i Step -1
    
26.             If ar(j) Like "【贮藏】*" Then x = j
    
27.             If ar(j) Like "【制剂】*" Then y = j
    
28.             If ar(j) Like "注：*" Then z = j
    
29.             If reg.test(ar(j)) And j > x Then py = j
    
30.         Next
    
31.         If x + 5 > y And y > x Then a = y Else a = x
    
32.         If x + 10 > z And z > x Then
    
33.             a = py - 2
    
34.         End If
    
35.         If a = 0 Then Exit For
    
36.         Do
    
37.             If n > 1 And ggg.test(ar(i)) And Not ggg.test(ar(i + 2)) Then
    
38.                 If InStr(br(n - 1, 16), "。") Then
    
39.                     br(n, 1) = Split(br(n - 1, 16), "。")(1)
    
40.                     br(n - 1, 16) = Split(br(n - 1, 16), "。")(0)
    
41.                     Exit Do
    
42.                 End If
    
43.             End If
    
44.             br(n, 1) = br(n, 1) & ar(i)
    
45.             i = i + 1
    
46.         Loop Until ggg.test(ar(i)) Or i = a Or ar(i) Like "【*"
    
47.         If reg.test(ar(i + 1)) Then
    
48.             br(n, 2) = ar(i)
    
49.             i = i + 1
    
50.             br(n, 3) = ar(i)
    
51.             i = i + 1
    
52.         ElseIf reg.test(ar(i)) Then
    
53.             br(n, 2) = ar(i)
    
54.             i = i + 1
    
55.         End If
    
56.         c = 3: reg.Pattern = "^(【[\u4e00-\u9fa5]+】|本品)"
    
57.         For j = i To a
    
58.             st = Trim(ar(j))
    
59.             If reg.test(st) Then
    
60.                 ss = reg.Execute(st)(0)
    
61.                 If d.exists(ss) Then c = d(ss)
    
62.             End If
    
63.             br(n, c) = br(n, c) & st
    
64.         Next
    
65.         i = a
    
66.     Next
    
67.     Application.ScreenUpdating = False
    
68.     With Sheets("EXCEL")
    
69.         .Rows("2:65536").Clear
    
70.         For i = 1 To n
    
71.             For j = 1 To UBound(br, 2)
    
72.                 .Cells(i + 1, j) = br(i, j)
    
73.             Next
    
74.         Next
    
75.     End With
    
76.     Application.ScreenUpdating = True
    
77. End Sub
    

复制代码

ak47ok

yangyangzhifeng 发表于 2013-6-17 08:01
试试这个

谢谢！
下标越界的提示的问题解决，原来是自己粗心将excel表中的第一行内容给清除了。

再次感激高手！