vba - Copying first two lines from multiple word documents into one excel document - Stack Overflow

admin管理员组

文章数量:1122846

I have searched and searched but have not been successful so far so here is my shot in the dark.

I have over 2,000 word docx files and I need to pull the first two lines out of them all and put them into one spreadsheet. There are no headers or footers in my documents. The first two lines are individual paragraphs. I would like the first line in one column and the second line in a different column if possible.

I have little to no experience with VBA so I am lost. What I have so far is this:

'''

Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("C:Desktop\Data Validation for Names\r013-001.docx", ReadOnly:=True)

Dim i As Long
i = 0
Dim wPara As Word.Paragraph
For Each wPara In wDoc.Paragraphs
    If wPara.Range.Words.Count > 1 Then
        wPara.Range.Copy
        Sheet1.Paste
        Destination = Sheet1.Range("A1").Offset(i, 0).Activate
        i = i + 1

    End If
Next wPara

wDoc.Close
wApp.Quit
End Sub

This is only for 1 document, I need it for all the documents, I have no idea how to do that. This also is for the whole document but when it comes into excel, it has some text in text boxes. How do I get that to stop?

I have searched and searched but have not been successful so far so here is my shot in the dark.

I have over 2,000 word docx files and I need to pull the first two lines out of them all and put them into one spreadsheet. There are no headers or footers in my documents. The first two lines are individual paragraphs. I would like the first line in one column and the second line in a different column if possible.

I have little to no experience with VBA so I am lost. What I have so far is this:

'''

Dim wApp As Word.Application
Dim wDoc As Word.Document
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open("C:Desktop\Data Validation for Names\r013-001.docx", ReadOnly:=True)

Dim i As Long
i = 0
Dim wPara As Word.Paragraph
For Each wPara In wDoc.Paragraphs
    If wPara.Range.Words.Count > 1 Then
        wPara.Range.Copy
        Sheet1.Paste
        Destination = Sheet1.Range("A1").Offset(i, 0).Activate
        i = i + 1

    End If
Next wPara

wDoc.Close
wApp.Quit
End Sub

This is only for 1 document, I need it for all the documents, I have no idea how to do that. This also is for the whole document but when it comes into excel, it has some text in text boxes. How do I get that to stop?

• excel
• vba
• ms-word

Share Improve this question Follow edited Nov 22, 2024 at 21:13 KCone asked Nov 22, 2024 at 18:16 KConeKCone 3155 bronze badges 2

• First part - stackoverflow.com/questions/11526577/… Second part is unclear - do your Word files contain textboxes? – Tim Williams Commented Nov 23, 2024 at 0:48
• Word works more simply with paragraphs or even sentences than it does with lines. – Charles Kenyon Commented Nov 23, 2024 at 5:13

Add a comment  | 

1 Answer 1

Sorted by: Reset to default 1

For example, to extract the first two paragraphs' text from all Word documents in a selected folder:

Sub GetDocData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Dim WkSht As Worksheet, r As Long, i As Long
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.Visible = False
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros True
'Disable any document alerts
wdApp.DisplayAlerts = wdAlertsNone
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  r = r + 1: WkSht.Cells(r, 1) = strFile
  Application.StatusBar = "Processing: " & strFile
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    For i = 1 To .Paragraphs.Count
      WkSht.Cells(r, i + 1) = Split(.Paragraphs(i).Range.Text, vbCr)(0)
      If i = 2 Then Exit For
    Next
    DoEvents
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
Application.StatusBar = ""
'Enable Word document alerts
wdApp.DisplayAlerts = wdAlertsNone
'Enable Word auto macros
wdApp.WordBasic.DisableAutoMacros False
'Quit Word
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
  Dim oFolder As Object
  GetFolder = ""
  Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
  If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
  Set oFolder = Nothing
End Function

A progress report is output on Excel's status bar.

本文标签： vbaCopying first two lines from multiple word documents into one excel documentStack Overflow