Import first line of text in each row/col of Word table to Excel using VBA

Question

I have a macro I am using to import the contents of tables in Word files into an Excel worksheet. The current script is working well, but there are times and error occurs in this line while processing a file where the contents of one of the columns becomes very lengthy:

  .Paste Destination:=.Range("A" & r)

I don't need the full contents of the text in each column. I would like to modify this to either copy only the first line of text or a defined number of characters in each row/column of the table.

Is there a way to do this?

Here is the script I am currently using:

Sub GetFirstTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Tables(1)
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13^l]"
        .Replacement.Text = Chr(182)
        .Forward = True
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
      End With
      .Columns.Add
      .Cell(1, 8).Range.Text = Split(strFile, ".doc")(0)
      .Range.Copy
    End With
    With ActiveSheet
      r = .Cells(.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then r = r + 2
      .Paste Destination:=.Range("A" & r)
    End With
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
ActiveSheet.UsedRange.Replace What:=Chr(182), Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = 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

Frooga Frooga · Accepted Answer · 2019-10-23T00:58:38

Turns out that the error was occurring because there were tables embedded in the tables being parsed, not due to the length of the body of text in the cell.

The hangup would occur on this line during the processing of the .docx file with the embedded tables:

.Paste Destination:=.Range("A" & r)

Once the tables were deleted from the file, the macro works like a champ!

Import first line of text in each row/col of Word table to Excel using VBA

1 Answers