Доброе время суток
Цитата |
---|
Slava977 написал: перенести таблицы Word в Excel |
Форум вроде как по Excel, ну да ладно
Код |
---|
Public Sub copyTableToExcelWorksheets()
Dim xlApp As Object, pBook As Object, pSheet As Object
Dim pTable As Table, i As Long, heads As Collection, head As Paragraph
Set pTable = ThisDocument.Tables(1)
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set pBook = xlApp.Workbooks.Add
Set heads = getHeaderCollection: i = 0
For Each pTable In ThisDocument.Tables
Set pSheet = pBook.Sheets.Add(After:=pBook.Sheets(pBook.Sheets.Count), Type:=-4167)
i = i + 1
Set head = heads(i)
head.Range.Copy
pSheet.PasteSpecial Format:="HTML"
pSheet.Range("A2").Select
pTable.Range.Copy
pSheet.PasteSpecial Format:="HTML"
Next
End Sub
Private Function getHeaderCollection() As Collection
Dim pPara As Paragraph, result As New Collection
For Each pPara In ThisDocument.Paragraphs
If pPara.OutlineLevel = wdOutlineLevel3 Then result.Add pPara
Next
Set getHeaderCollection = result
End Function
|