使用VBA，我想把MS Word文档中的所有文本复制到MS Excel中，Excel列出了文档和它们的位置。

Question

我之前问这个问题的方式不一样，没有任何代码，所以被关闭了。现在我已经写了一些代码，我想我已经接近了，但还是遇到了错误，希望能得到一些帮助。

下面是我基本上要完成的任务，为了清楚起见，简化了一下。

假设我在windows电脑上有一个本地文件夹 叫做 "我的文档"，里面有以下文件，都是MS Word文档。

*C:\My Documents\
 Document 1.docx
 Document 2.docx
 Document 3.docx
 Document 4.docx*

另外，我有一个excel电子表格，其中列出了以下内容。

*Filename (A)  Directory (B)            Content (C)  
 Document 1    C:\...\Document 1.docx   blank        
 Document 2    C:\...\Document 2.docx   blank        
 Document 3    C:\...\Document 3.docx   blank        
 Document 4    C:\...\Document 4.docx   blank        *

我的Word文档中实际上有以下文字（没有其他内容）。

*Document 1 - I want this text in Column (C), Row 1
 Document 2 - I want this text in Column (C), Row 2
 Document 3 - I want this text in Column (C), Row 3
 Document 4 - I want this text in Column (C), Row 4*

我想在Microsoft Excel里面写一些可视化的基本代码，指示它做以下事情。

对于电子表格中的每一行

 `1. open the file from column B
  2. take all the text in the document (e.g. select all, WholeStory?)
  3. Insert that text in the cell in column D for the row we are working on`

...... 重复我的电子表格中的所有记录

我期望的结果是这样的。

*Filename (A)  Directory (B)            Content (C)                           
Document 1     C:\...\Document 1.docx   I want this text in Column (C), Row 1 
Document 2     C:\...\Document 2.docx   I want this text in Column (C), Row 2 
Document 3     C:\...\Document 3.docx   I want this text in Column (C), Row 3 
Document 4     C:\...\Document 4.docx   I want this text in Column (C), Row 4   *

在现实中，我有将近300个文档需要去看， 而且我需要多次做这个练习， 所以我想把它自动化。

这是我目前的代码，我把它注释得很死，试图解释我认为我在做什么。

Sub GetWordText()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.

'define variables (i have some extras for different things I tried that didn't work)
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strDoc As String
Dim strProc As String
Dim r As Long
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
Dim body As String

'set some settings
wdApp.Visible = False
wdApp.WordBasic.DisableAutoMacros

'start working with my excel sheet
 With ActiveSheet

'start loop to go through rows one by one
'starts at r=2 because the sheet has headers
 For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
  strDoc = .Range("B" & r).Text

'make sure there is actually a file to process
 If strDoc <> "" Then
  If Dir(strDoc) = "" Then
    MsgBox "Cannot find:" & vbCr & strDoc, vbExclamation

  'when there is something to process, do this
  Else

    'opens the word doc specified in column B
    Set wdDoc = wdApp.Documents.Open(Filename:=strDoc, AddToRecentFiles:=False, Visible:=False)

    '--- EVERYTHING ABOVE THIS WORKS
    '--- NOW I NEED TO COPY THE WORD DOC INTO THE EXCEL CELL IN COLUMN D FOR THIS ROW

    'This next code line throws an error:
    'Object variable or full width vairable not set
    'I thought it would select all of the text in my word doc
    wdApp.Selection.WholeStory

    'then copy the selected text
    wdApp.Selection.Copy

    'paste it into content column for the document's row
    ActiveSheet.Paste Destination:=Worksheets("Sheet1").Range("C" & r)

    'close the word doc
    wdDoc.Close SaveChanges:=True

     End If
   End If
  Next
End With
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

Answer 1

你只需要在

'opens the word doc specified in column B
Set wdDoc = wdApp.Documents.Open(Filename:=strDoc, AddToRecentFiles:=False, Visible:=False)

和:

'close the word doc
wdDoc.Close SaveChanges:=False ' Note False

是。

'update the worksheet with the document content, merging paragraphs
.Range("C" & r).Value = Replace(wdDoc.Range.Text, vbCr, Chr(182))

最后，在..:

Next

插入。

'reformat the imported data into paragraphs.
.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows