VBA代码批量提取带有控件的模板Word表格，版主大神帮修改完善代码，急求

candy荔枝

表格数据，现有代码，要求的效果都在附近里，求大神帮看看怎么修改。谢谢啦

candy荔枝

我用的是office 2010版

junhua_zhu

看了代码，您已经是大神了。

candy荔枝

junhua_zhu 发表于 2014-4-23 20:35
看了代码，您已经是大神了。

先谢谢您，这些不是我写的，我是需要在此基础上改完善

zhanglei1371

你的意思是否是提取嵌入式域中的word文档的表格？
你的表述有问题，因为从代码来看，已经是成型代码了。提供的附件中的文件打开总提示需要转换器。
至于表格，最后用2010打开后发现是内嵌入的控件，可以使用ole对象方法：Set olindoc = lindoc.InlineShapes(1).OLEFormat.Object来取得图像控件里表格的内容，稍作修改如下：【具体自己再修改下】
最终完成代码：

1. Public astring As String
   
2. '互函得到对话框中所有的文件路径＋文件名
   
3. Function filename1()  '此代码功能为列出指定文件夹中所有选取的WORD文件全路径名
   
4.     Dim MyDialog As FileDialog
   
5.     On Error Resume Next '忽略错误
   
6.     '定义一个文件夹选取对话框
   
7.     Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
   
8.     With MyDialog
   
9.         .Filters.Clear    '清除所有文件筛选器中的项目
   
10.         .Filters.Add "所有 WORD 文件", "*.doc;*.docx", 1    '增加筛选器的项目为所有WORD文件
    
11.         .AllowMultiSelect = True    '允许多项选择
    
12.         If .Show = -1 Then    '确定
    
13.             For Each vrtSelectedItem In .SelectedItems    '在所有选取项目中循环
    
14.                 filename1 = filename1 & Chr(13) & vrtSelectedItem   '列出所有文件名
    
15.             Next vrtSelectedItem
    
16.         End If
    
17.       
    
18.     End With
    
19. End Function
    
20. Sub 主程序()
    
21.     Dim arr
    
22.     Dim arr1
    
23.    
    
24.     Dim astring As String
    
25.     Application.ScreenUpdating = False
    
26. '    On Error Resume Next '忽略错误
    
27.    
    
28.     Application.StatusBar = "程序正在运行，请稍等！......(看到这个，说明一切正常)"
    
29.    
    
30.     astring = filename1 '文件名
    
31.     If astring = "" Then
    
32.         MsgBox "你没有选择任何文件"
    
33.         Exit Sub
    
34.     Else
    
35.         astring = Mid(astring, 2, Len(astring) - 1) '去掉第一个chr(13)
    
36.         arr = Split(astring, Chr(13))
    
37.         具体 (arr)
    
38.     End If
    
39.     Application.StatusBar = "程序已正确运行完毕！"
    
40.     Application.ScreenUpdating = True
    
41. End Sub
    
42. Function 具体(arr)
    
43.     Dim lindoc As Word.Document
    
44.     Dim appword As Word.Application
    
45.     Dim i As Long
    
46.     Dim a
    
47.     Dim aend As Long
    
48.     Dim wordcell%, alin As String
    
49.     Dim arr2, j%, k%
    
50. 
    
51. 
    
52.     Set appword = GetObject(, "Word.Application")
    
53.     If Err.Number > 0 Then
    
54.         Set appword = CreateObject("word.Application")
    
55.     End If
    
56.     aend = Range("A65536").End(xlUp).Row + 1  '算得下一行行号
    
57.     ReDim arr2(UBound(arr), 40)    '重定位数组，40是分工加的，可以改。改的话，要计算表格有多少个单元格
    
58. 
    
59.     For Each arr1 In arr
    
60.         arr2(i, 0) = aend - 2
    
61.         Range("P3:P3").Formula = "=A1 &2"
    
62.         Cells.HorizontalAlignment = xlCenter
    
63.         Cells.WrapText = True  '自动换行
    
64.         Cells.EntireColumn.AutoFit  '行高根据内容自动调整
    
65.         Cells.EntireRow.AutoFit
    
66.         k = 1
    
67.         Set lindoc = appword.Documents.Open(Filename:=arr1, Visible:=True)
    
68.         Application.StatusBar = "正在处理第" & i + 1 & "个文档，共" & UBound(arr) + 1 & "文档。..."
    
69.         With lindoc.Tables(1).Range
    
70.             For wordcell = 2 To .Cells.Count Step 2    '以2为循环
    
71.                 Debug.Print .Cells(wordcell).Range.Fields.Count
    
72.                 If .Cells(wordcell).Range.Fields.Count > 0 Then
    
73.                     Dim f As Field, s As InlineShape
    
74.                     For Each s In .Cells(wordcell).Range.InlineShapes
    
75.                         If s.OLEFormat.Object.Value = True Then
    
76.                             alin = s.OLEFormat.Object.Caption
    
77.                             arr2(j, k) = alin
    
78.                         End If
    
79.                     Next
    
80.                 Else
    
81.                     alin = .Cells(wordcell).Range.Text
    
82.                 arr2(j, k) = Mid(alin, 1, Len(alin) - 2)    '去掉后面的制表符
    
83.                 End If
    
84.                 k = k + 1    '转入下一列
    
85.             Next
    
86.         End With
    
87.         lindoc.Close    '关闭文档
    
88.         i = i + 1    '累加要处理的处理数
    
89.         j = j + 1    '转入下一行
    
90.     Next
    
91.     Range("a" & aend & ":M" & aend + UBound(arr)) = arr2    '数组附值
    
92.     Columns("H:H").Hidden = True
    
93.     Columns("K:K").Hidden = True
    
94.     Columns("L:L").Hidden = True
    
95.     Columns("N:N").Hidden = True
    
96.     Columns("P:P").Hidden = True
    
97.     Columns("r:r").Hidden = True
    
98. 
    
99.     appword.Quit    '退出Word
    
100.     Set lindoc = Nothing
     
101.     Set appword = Nothing
     
102. 
     
103. End Function
     

复制代码

candy荔枝

zhanglei1371 发表于 2014-4-24 15:54
你的意思是否是提取嵌入式域中的word文档的表格？
你的表述有问题，因为从代码来看，已经是成型代码了。提 ...

您好，首先感谢您帮我修改了代码，但是我打开还是一样哦，无法提取到Word控件中的内容，现在是打不开了，一直处于运行直到无响应

candy荔枝

这是现在的截图，无法响应了。请问不需要在代码中调用控件的属性是否选中这样吗？谢谢

candy荔枝

继续求帮忙啊，谢谢