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

[dzogchen]

Hi evereryone,

With the follwing procedure which intends to retrieve specific text (red square in the above image) from word documents:
Proposta.jpg

Sub Abrir()


Dim FolderName As String
Dim FileName As String
Dim NewDoc As Object
Dim NewWordFile As Object


Dim A As String
Dim r As Integer




Range("A2:B1000").Value = ""
Range("A2").Select


r = 2


FolderName = "C:\Users\njesus\Documents\Os meus documentos\"
FileName = Dir(FolderName & "*.doc*")




Do While FileName <> ""


On Error Resume Next
    Set NewDoc = CreateObject("word.application")
    NewDoc.Application.Visible = False
    Set NewDoc = GetObject(FolderName & FileName)


    A = NewDoc.Range(12, 25)
    Range("A" & r).Value = A
  
    A = NewDoc.Range(200, 500)
    Range("B" & r).Value = A
   
r = r + 1
   
    NewDoc.Close SaveChanges:=wdDoNotSaveChanges
    NewWordFile.Quit
          
FileName = Dir()


Set NewDoc = Nothing
Set NewWordFile = Nothing


Loop


End Sub

works for folders with a few word documents, but for folders with more than 100 documents it is creating huge amount of data and I keep run out of disk space. Can anyone help me understanding why is this happening?

Thank you!

Regards

[georgiboy]

You could try it like the below, there were too many bits inside the loop:

Sub Abrir()
    Dim FolderName As String
    Dim FileName As String
    Dim wdApp As Object
    Dim NewDoc As Object

    Range("A2:B" & Rows.Count).ClearContents

    FolderName = "C:\Users\njesus\Documents\Os meus documentos\"
    FileName = Dir(FolderName & "*.doc*")
    Set wdApp = CreateObject("word.application")
    wdApp.Application.Visible = False
    
    Do While FileName <> ""
        Set NewDoc = GetObject(FolderName & FileName)
        Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Resize(, 2).Value = Array(NewDoc.Range(12, 25), NewDoc.Range(200, 500))
        NewDoc.Close SaveChanges:=False
        FileName = Dir()
    Loop
    
    wdApp.Quit
End Sub

[snb]

Keep it simple.
Avoid 'On error Resume Next'

Sub M_snb()
  c00="C:\Users\njesus\Documents\Os meus documentos\"
  c01= Dir(c00 & "*.doc*")

  do while c01<>""
    with getobject(c00 & c01)
      c02=c02 & vblf & .paragraphs(7).range.text
      .close 0
    end with
    c01=Dir
  loop

  Msgbox c02
End Sub

[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

[dzogchen]

Hi,

Thank you all for your reply!

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.

True! In the meanwhile i remember to opened the windows task bar and saw a bunch of word documents tasks opened, it was that what was filling my disk, so I changed the "CreateObject("word.application")" to "GetObject("word.application")" and it worked, but since the code is not optimized it takes around 1h to do 150 documents....

macropod it was that code that I was looking for, it works like a charm! thank you very much!!!