求助高手

求助高手，把word的内容转换成要求的excel内容

1. Sub 粘贴word_芐雨()
   
2.     Dim wdApp
   
3.     Set wdApp = CreateObject("word.application")
   
4.     Application.ScreenUpdating = False
   
5.     Set sht = ActiveSheet
   
6.     wdpath = ThisWorkbook.Path & "\new_fortune.docx"    '文档路径
   
7.     ' On Error Resume Next
   
8.     Set wDoc = wdApp.documents.Open(wdpath)
   
9. 
   
10.     wDoc.Tables(1).Select
    
11.     wDoc.ActiveWindow.Selection.Copy
    
12.     sht.Activate
    
13.     sht.[G1].Select
    
14.     sht.PasteSpecial Format:="Unicode 文本", Link:=False, DisplayAsIcon:=False
    
15.     wdApp.Quit
    
16.     Set wdApp = Nothing
    
17.     Call t
    
18.     MsgBox "完成!!!!"
    
19.     Application.ScreenUpdating = True
    
20. End Sub
    
21. 
    
22. 
    
23. Sub t()
    
24.     Dim brr(1 To 3000, 1 To 4)
    
25.     arr = [G1].CurrentRegion
    
26.     On Error Resume Next
    
27.     For i = 1 To UBound(arr)
    
28. 
    
29.         tmp = Replace(Replace(Replace(StrConv(arr(i, 2), 4), "［微博］", ""), "等）", "）"), "　", "")
    
30.         s = Split(tmp, "；")
    
31.         For j = 0 To UBound(s)
    
32.             t1 = arr(i, 1)
    
33.             If InStr(s(j), "名：") > 0 Then
    
34.                 S2 = Split(s(j), "名：")
    
35.                 t2 = Mid(S2(0), 2)
    
36.                 If InStr(S2(1), "研究小组（") > 0 Then
    
37. 
    
38.                     s3 = Split(S2(1), "研究小组（")
    
39.                     t3 = s3(0)
    
40. 
    
41.                     s4 = Split(Split(s3(1), "）")(0), "、")
    
42.                     For n = 0 To UBound(s4)
    
43.                         x = x + 1
    
44.                         brr(x, 1) = t1
    
45.                         brr(x, 2) = t2
    
46.                         brr(x, 3) = Replace(t3, "：", "")
    
47.                         brr(x, 4) = s4(n)
    
48.                     Next
    
49.                 Else
    
50. 
    
51.                     If InStr(S2(1), "证券") > 0 Then
    
52.                         s3 = Split(S2(1), "证券")
    
53.                         t3 = s3(0) & "证券"
    
54.                         x = x + 1
    
55.                         brr(x, 1) = t1
    
56.                         brr(x, 2) = t2
    
57.                         brr(x, 3) = Replace(t3, "：", "")
    
58.                         brr(x, 4) = Replace(s3(1), "：", "")
    
59.                     Else
    
60.                         s3 = Split(S2(1), "公司")
    
61.                         t3 = s3(0) & "公司"
    
62.                         x = x + 1
    
63.                         brr(x, 1) = t1
    
64.                         brr(x, 2) = t2
    
65.                         brr(x, 3) = Replace(t3, "：", "")
    
66.                         brr(x, 4) = Replace(s3(1), "：", "")
    
67.                     End If
    
68.                 End If
    
69.             End If
    
70.         Next
    
71.     Next
    
72.     Range("A2:D" & Rows.Count).Clear
    
73.     Range("G:H").Clear
    
74.     Range("A2").Resize(x, 4) = brr
    
75. End Sub

复制代码

代码放入excel中，两个文件必须在同一路径中，你测试一下
粘贴word_芐雨.zip (40.72 KB) 本附件包括：

• new_fortune.xlsm
• new_fortune.docx

2015-10-12 15:48:57 上传

粘贴到excel中再写个vba啊

word里面没有内容？补充一下附件吧，要写VBA也要看实际例子

芐雨 发表于 2015-10-12 09:05
word里面没有内容？补充一下附件吧，要写VBA也要看实际例子

我下载了word看看，里面有内容啊

芐雨 发表于 2015-10-12 09:05
word里面没有内容？补充一下附件吧，要写VBA也要看实际例子

非常感谢   有空能否添加一些关键的注释    我对vba不是很了解    大概还有十个这样的文件要处理