нашел код в расширение темы
авторI have a have directory full of word documents=2E Each document=
>> has a standard Word =93table of contents=94=2E Each TOC has the same=
>> entry, specifically =936=2E Business Process=2E=94 Under this section=
>> is a table; It most likely will be on a different page (number)=
>> in each document=2E I'm trying to figure out how to open each word=
>> document & then copy the table in its entirety to an Excel=
>> spreadsheet=2E Loop and do the next file in the directory, and the=
>> program can keep adding to the same spreadsheet=2E
>>
>>I'm having some difficulty getting started on this since I=
>> haven't worked with VB & MS Word too much=2E Can anyone give me=
>> some pointers? Thanks!
авторAssuming you have the path in a textbox named txtDocsPath and the file names loaded into a listbox named lstWDocs:
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
Private Sub mnuRipEmAll_Click()
Dim pddFile As Integer
For pddFile = 0 To lstWFiles.ListCount - 1
lstWFiles.ListIndex = pddFile
ScanDocumentForTable txtDocsPath.Text, Left(lstWFiles.Text, Len(lstWFiles.Text) - 4 )
'remove file extension to make it easier to save as xls file
Next pddFile
End Sub
Public Sub ScanDocumentForTable(sDocPath As String, wdDocName As String)
Dim WordDocument As Object
Dim wdApp As Object
Set wdApp = GetObject("", "Word.Application")
DoEvents
wdApp.Application.Documents.Open sDocPath & wdDocName & ".doc"
wdApp.Application.Visible = False
DoEvents
If wdApp.ActiveDocument.Tables.Count >= 1 Then
Dim tblNumber As Integer
For tblNumber = 1 To wdApp.ActiveDocument.Tables.Count
If Left(wdApp.ActiveDocument.Tables(tblNumber), 9 ) = "Step Type" Then
wdApp.ActiveDocument.Tables(tblNumber).Range.Copy
Dim ExcelSheet As Object
Set ExcelSheet = CreateObject("Excel.Sheet")
ExcelSheet.Application.Visible = False
DoEvents
ExcelSheet.ActiveSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False, NoHTMLFormatting:=True
ExcelSheet.ActiveSheet.Rows("1:1").Font.Bold = True
ExcelSheet.Application.Cells.Font.Name = "Courier New"
ExcelSheet.Application.Cells.Font.Size = 10
ExcelSheet.Application.Cells.EntireColumn.Autofit
ExcelSheet.SaveAs sDocPath & wdDocName & ".xls"
ExcelSheet.Application.Quit
wdApp.Application.Quit
Set ExcelSheet = Nothing
Set wdApp = Nothing
Exit For
End If
Next tblNumber
End If
End Sub
