Copy text from word to excel - "Out of disk space" error

[macropod]

Undoubtedly, creating multiple Word instances that you don't kill has choked your system(Hint: NewWordFile.Quit does not relate to Set NewDoc = CreateObject("word.application")). Your code has other issues, too.

Here's a more flexible approach that allows for the possibility that doesn't require knowing in advance which paragraphs contain your strings or, especially for the second string, how long it might be:

Sub Abrir()
Dim StrFldr As String, StrFlNm As Strin, WdObj As Object, WdDoc As Object, xlSht As Worksheet, r As Long
StrFldr = "C:\Users\njesus\Documents\Os meus documentos\": r = 1
Set WdObj = CreateObject("Word.Application"): WdObj.Visible = False
Set xlSht = ActiveSheet: xlSht.Range("A2:B" & Rows.Count).ClearContents
StrFlNm = Dir(StrFldr & "*.doc*")
Do While StrFlNm <> ""
  r = r + 1
  Set WdDoc = WdObj.Documents.Open(StrFldr & StrFlNm)
  With WdDoc
    With .Range
      With .Find
        .MatchWildcards = True
        .Text = "N/O Ref[!\:]@:[!/]@/[! ]@>"
        .Execute
      End With
      If .Find.Found Then xlSht.Range("A" & r).Value = Split(.Text, ":")(1)
    End With
    With .Range
      With .Find
        .MatchWildcards = True
        .Text = "ASSUNTO:[!^13]@^13"
        .Execute
      End With
      If .Find.Found Then xlSht.Range("B" & r).Value = Split(.Text, "ASSUNTO:")(1)
    End With
    .Close False
  End With
  StrFlNm = Dir()
Loop
Set WdDoc = Nothing: Set WdObj = Nothing: Set xlSht = Nothing
End Sub