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

Hi evereryone,

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

Code:

---

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

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

Code:

---

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

---

Keep it simple.
Avoid 'On error Resume Next'

Code:

---

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

---

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:

Code:

---

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

---

Hi,

Thank you all for your reply!

Quote:

---

Originally Posted by 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.

---

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 :bow: it was that code that I was looking for, it works like a charm! thank you very much!!! :bow: