跪求大师优化一下我的 VBA

救赎0003

各位 VBA 版块的大师们，上午一个好心人帮我设计了一个VBA  EXCEL (附件），我找到问题点了，这个是一对一的提取数据，EXCEL 单元格1= word'单元格**             可以我发现word经常型号下面一栏 是变量，有时候8个，少的时候1个， 可否修改为  匹配数据描述为：  提取  型号 芯数  数量 盘长 下面1-9  个数据（没有数据就算了）   交货地址，等等 就是word 右边单元格 内容。这样就对了。

dyp1610

1. Sub 从Word中提取数据到Excel中()
   
2.   Dim WrdDocApp As Object, FSO As Object, wordFilePath, wordFilename, arr(), brr()
   
3.   Application.ScreenUpdating = False
   
4.   Set WrdDocApp = CreateObject("Word.Application")    '用Set关键词创建Word应用程序对象！
   
5.   Set FSO = CreateObject("Scripting.FileSystemObject") '文件系统对象
   
6.   Set wordFilePath = FSO.GetFolder(ThisWorkbook.Path)  '获取文件夹的路径
   
7.   
   
8.   wordFilename = Dir(wordFilePath & "\*.doc*") '循环查找Word,可以适应不同版本 具体提取哪类文件,根据文件扩展名进行处理
   
9.   Do While wordFilename <> ""  '在目录中循环
   
10.     n = 0
    
11.     m = 0
    
12.    
    
13.   On Error Resume Next
    
14.   Set WrdDoc = GetObject(wordFilePath & "" & wordFilename) '使用此代码 ,打开Word文件 视窗会自动隐藏(给人的感觉是没有打开做的操作)
    
15.   
    
16.   ReDim arr(1 To 20, 1 To 10) '重新定义数组arr
    
17.   With WrdDoc.Tables(1) '提取Word文件内第1页的第1个表格内容
    
18.   Rem 第一部分
    
19.     arr(1, 1) = WorksheetFunction.Clean(.cell(1, 4).Range.Text) '合同号
    
20.     arr(1, 2) = WorksheetFunction.Clean(.cell(2, 2).Range.Text) '工程名称
    
21.     arr(1, 3) = WorksheetFunction.Clean(.cell(2, 4).Range.Text) '销售单号
    
22.     arr(1, 8) = WorksheetFunction.Clean(.cell(3, 2).Range.Text) '交货地址1
    
23.   x = .Rows.Count
    
24.   For i = 5 To x
    
25.         y = WorksheetFunction.Clean(.cell(i, 1).Range.Text)
    
26.         If y <> "收货人" Then
    
27.         n = n + 1
    
28.         ReDim Preserve brr(1 To 4, 1 To n)
    
29.         brr(1, n) = WorksheetFunction.Clean(.cell(i, 2).Range.Text)
    
30.         brr(2, n) = WorksheetFunction.Clean(.cell(i, 3).Range.Text)
    
31.         brr(3, n) = WorksheetFunction.Clean(.cell(i, 4).Range.Text)
    
32.         brr(4, n) = WorksheetFunction.Clean(.cell(i, 5).Range.Text)
    
33.         Else
    
34.             m = i
    
35.             Exit For
    
36.         End If
    
37.         
    
38.   Next
    
39.    
    
40.     arr(1, 9) = WorksheetFunction.Clean(.cell(m, 2).Range.Text) '收货人1
    
41.     arr(1, 10) = WorksheetFunction.Clean(.cell(m, 4).Range.Text) '联系电话1
    
42.    
    
43.     Rem 第二部分
    
44.     arr(n + 1, 8) = WorksheetFunction.Clean(.cell(m + 1, 2).Range.Text) '交货地址2
    
45.     arr(n + 1, 9) = WorksheetFunction.Clean(.cell(x, 2).Range.Text) '收货人2
    
46.     arr(n + 1, 10) = WorksheetFunction.Clean(.cell(x, 4).Range.Text) '联系电话2
    
47. 
    
48.   For i = m + 3 To x - 1
    
49.         y = WorksheetFunction.Clean(.cell(i, 1).Range.Text)
    
50.         If y <> "收货人" Then
    
51.         n = n + 1
    
52.         ReDim Preserve brr(1 To 4, 1 To n)
    
53.         brr(1, n) = WorksheetFunction.Clean(.cell(i, 2).Range.Text)
    
54.         brr(2, n) = WorksheetFunction.Clean(.cell(i, 3).Range.Text)
    
55.         brr(3, n) = WorksheetFunction.Clean(.cell(i, 4).Range.Text)
    
56.         brr(4, n) = WorksheetFunction.Clean(.cell(i, 5).Range.Text)
    
57.         Else
    
58.             Exit For
    
59.         End If
    
60.         
    
61.   Next
    
62.   
    
63.    
    
64.     End With
    
65.     myrows = Cells(Rows.Count, 4).End(3).Row + 1
    
66.     Range("A" & myrows).Resize(n, 10) = arr '把提取的内容赋值给Excel工作表
    
67.     Range("D" & myrows).Resize(n, 4) = Application.Transpose(brr)
    
68.     Erase arr  '重新初始化arr数组
    
69.     Erase brr
    
70.     With Range("A2:J" & Cells(Rows.Count, 4).End(3).Row) '设定格式
    
71.     .Font.Size = 11: .Borders.Value = 1
    
72.     .HorizontalAlignment = xlCenter
    
73.     .VerticalAlignment = xlCenter
    
74.     End With
    
75.     Range("H2:H" & Cells(Rows.Count, 4).End(3).Row).HorizontalAlignment = xlLeft  '设定格式
    
76.     Columns("A:J").EntireColumn.AutoFit '自动栏宽
    
77. '  WrdDoc.Close    ' 关闭Word文件
    
78.     WrdDocApp.Quit  '关闭Word程序
    
79.     Set WrdDocApp = Nothing '释放Word程序
    
80.     wordFilename = Dir
    
81.   Loop '结束循环
    
82. Application.ScreenUpdating = True
    
83. End Sub
    

复制代码