Copying first two lines from multiple word documents into one excel document

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?

Solution

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.