從Word導出目錄到Excel

我正在尋找一種方法來從Word中獲取目錄（不是已創建，但標題可用），並在Excel上存儲章節編號和標題。有沒有一種方法使用Excel VBA將word doc中的標題轉換爲excel？我已經搜索過這個，但是大家都建議使用粘貼特殊，但是我希望它自動化，因爲TOC中的數據在之後在Excel中被分類到不同的表中。從Word導出目錄到Excel

Sub importwordtoexcel() 
    MsgBox ("This Macro Might Take a While, wait until next Message") 
    Application.ScreenUpdating = False 
    Sheets("Temp").Cells.Clear 

    'Import all tables to a single sheet 
    Dim wdDoc As Object 
    Dim wdFileName As Variant 
    Dim TableNo As Integer 'table number in Word 
    Dim iRow As Long 'row index in Word 
    Dim jRow As Long 'row index in Excel 
    Dim iCol As Integer 'column index in Excel 
    wdFileName = Application.GetOpenFilename("Word files    (*.docx),*.docx", , _ 
"Browse for file containing table to be imported") 
If wdFileName = False Then Exit Sub '(user cancelled import file browser) 
Set wdDoc = GetObject(wdFileName) 'open Word file 
With wdDoc 
    If wdDoc.Tables.Count = 0 Then 
     MsgBox "This document contains no tables", _ 
     vbExclamation, "Import Word Table" 
    Else 
     jRow = 0 
     For TableNo = 1 To wdDoc.Tables.Count 
      With .Tables(TableNo) 
       'copy cell contents from Word table cells to Excel cells 
       For iRow = 1 To .Rows.Count 
        jRow = jRow + 1 
        For iCol = 1 To .Columns.Count 
         On Error Resume Next 
         Sheets("Temp").Cells(jRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) 
         On Error GoTo 0 
        Next iCol 
       Next iRow 
      End With 
      jRow = jRow + 1 
     Next TableNo 
    End If 
End With 
Set wdDoc = Nothing 

'Takes data from temp to RTM_FD 
Dim nRow As Long 
Dim mRow As Long 
Dim Temp As Worksheet 
Dim RTM As Worksheet 
Set Temp = Sheets("Temp") 
Set RTM = Sheets("RTM_FD") 

mRow = 16 
For nRow = 1 To Temp.Rows.Count 
    If Temp.Cells(nRow, 1).Value = "Position" Or Temp.Cells(nRow, 1).Value = "" Then 
    Else 
     RTM.Cells(mRow, 1).Value = Temp.Cells(nRow, 1) 
     RTM.Cells(mRow, 2).Value = Temp.Cells(nRow, 4) 
     RTM.Cells(mRow, 2).Font.Bold = False 
     RTM.Cells(mRow, 3).Value = Temp.Cells(nRow, 5) 
     RTM.Cells(mRow, 3).Font.ColorIndex = 32 
     If Temp.Cells(nRow, 3).Value = "P" Then 
      RTM.Cells(mRow, 9).Value = "X" 
      RTM.Cells(mRow, 9).Interior.ColorIndex = 44 
     ElseIf Temp.Cells(nRow, 3) = "Q" Then 
      RTM.Cells(mRow, 7).Value = "X" 
      RTM.Cells(mRow, 7).Interior.ColorIndex = 44 
     ElseIf Temp.Cells(nRow, 3) = "TA" Then 
      RTM.Cells(mRow, 8).Value = "X" 
      RTM.Cells(mRow, 8).Interior.ColorIndex = 44 
     Else 
     End If 
     mRow = mRow + 1 
    End If 
Next nRow 

Application.ScreenUpdating = True 
MsgBox ("DONE") 
Sheets("Temp").Cells.Clear 
Dim SaveName As String 
SaveName = InputBox("What Do You Want to Save the File As:") 
ActiveWorkbook.SaveAs (SaveName) 
MsgBox ("Your file is saved as " & SaveName) 
MsgBox ("Please Accept Delete Operation") 
Sheets("Temp").Delete 
ActiveWorkbook.Save 
End Sub

來源

2016-02-23 Mert Karakaya

你必須先嚐試不同的方法，首先看看什麼對你有用，什麼不是，如果卡住了，你可以在這裏尋求幫助。 – newguy

@Santosh複製和粘貼工程，但我試圖將它集成到現有的代碼，並且該代碼是我第三次嘗試優化某些東西。最後它起作用。它不適用於我有TOC代碼的word vba，但對於Excel，我甚至不知道從哪裏開始。 –

開始。在Excel中，添加對Word的引用。創建一個WordDoc對象。將其設置/打開到您要閱讀的單詞文檔。訪問表，從表中讀取，寫入單元格... – MatthewD

一種方式來獲得部分的標題，而無需創建一個TOC是與選擇對象上迭代，使用Selection.Goto。以下示例將文檔中的所有節標題打印到直接窗口中。我相信你可以將這個概念適應你的代碼。

Sub PrintHeadings() 
Dim wrdApp As Word.Application 
Dim wrdDoc As Document 
Dim Para As Paragraph 
Dim oldstart As Variant 

Set wrdApp = CreateObject("Word.Application") 'open word 
Set wrdDoc = wrdApp.Documents.Open("C:\sample.docx", , True, False, , , , , , , , True) 'open file 

wrdDoc.ActiveWindow.ActivePane.View.Type = wdPrintView 'avoids crashing if opens on read view 

    With wrdDoc.ActiveWindow.Selection 
    .GoTo What:=wdGoToHeading, which:=wdGoToFirst 'go to first heading 
    Do 
     Set Para = .Paragraphs(1) 'get first paragraph 
     Title = Replace(Para.Range.Text, Chr(13), "") 'gets title and remove trailing newline 
     Debug.Print Title, "pg. "; .Information(wdActiveEndAdjustedPageNumber) 'prints title and page to console 
     oldstart = .Start 'stores position 
     .GoTo What:=wdGoToHeading, which:=wdGoToNext 'go to next heading 
     If .Start <= oldstart Then Exit Do 'if looped around to first section (i.e. new heading is before old heading) we are done 
    Loop 
    End With 

    wrdDoc.Close 
    wrdApp.Quit 

    Set Para = Nothing 
    Set wrdDoc = Nothing 
    Set wrdApp = Nothing 

End Sub

我使用早期綁定，所以你要麼需要添加引用到Word對象模型，或調整代碼到後期綁定（包括找出枚舉的數值）。

來源

2016-02-23 16:34:03 dnep

從Word導出目錄到Excel

回答

相關問題