Percorrer arquivo .doc

Question

Olá,

Gostaria de criar um vba para ler os arquivos .doc (word) de uma pasta. Depois percorrer as linhas desses documento. Pegar determinada parte (range) do texto e gravar em um outro arquivo.

Se alguém souber fazer pelo menos parte.. já me ajuda muito!

Se não fui claro com a dúvida.. só falar que explico mais detalhadamente.

Obrigado

[]'s

Answer 1

 

Achei este link ensinando a escrever

e modifiquei adicionando um for ate o final dos paragrafos do doc para ler tds.

o cód editado ficou assim

 

Sub LerDocumento()
   
    'Declarações
    Dim appWord As word.Application
    Dim doc As word.Document
    Dim prg As word.Paragraph
    Dim rng As word.Range
   
    'A Aplicação é criada aqui:
    Set appWord = CreateObject("Word.Application")
    'A linha abaixo é importante: você deve querer que
    'sua aplicação seja visível na maioria das vezes
    appWord.Visible = True
   
    'Note que, na linha abaixo, foi adicionado um Documento
    'dentro da Aplicação appWord:
    Set doc = appWord.Documents.Open("C:\Tema.doc")
    'Da mesma forma, é atribuído ao Parágrafo prg o primeiro
    'parágrafo existente do Documento doc.

 

' Parte adicionada com ambas as estruturas consegui ler um doc

' Feito com for each para todos os paragrafos 
    For Each c In doc.Paragraphs
    teste = c
    Next

'feito com for de 1 ate quantidade de paragrafos do documento
    For i = 1 To doc.Paragraphs.Count
        Set prg = doc.Paragraphs(i)
        linha = prg.Range.Text
    Next i
   
   
    'Apenas para limpar memória
    Set rng = Nothing
    Set prg = Nothing
    Set doc = Nothing
    Set appWord = Nothing
   
End Sub

 

e o link de onde retirei o código é este

http://www.ambienteoffice.com.br/word/criar_uma_instancia_do_word_pelo_vba/

se caso achar outra coisa poste

pois essa leitura de arquivo e bastante interassante.

 

Abrç

 

 

Answer 2

Jhonatan,

Valeu pelo esforço em me ajudar, mas eu não tenho muito conhecimento em VBA.

Não sei como eu poço aplicar esse código no que preciso.

Se você puder me ajudar, fico grato.

Preciso fazer os seguintes passos:

1. A partir de um ou mais documentos word em uma pasta

2. Ler eles. Como eles estão em template, os títulos dos parágrafos são iguais.

3. Pegar os parágrafos que contenham título igual a "xxxxxx" e título "eeeee". Ler o documento até encontrar o título passado e gravar o conteúdo que está em baixo dele. No caso, eu acho que daria pra fazer lendo o conteúdo e parar de percorrer quando encontrar uma linha em branco, e continuar lendo até encontrar o outro título que está buscando pra gravar também.

4. Quando estiver percorrendo ir gravando em um outro documento.

 

Obrigado

[]'s

 

Answer 3

Koah

 

Se possivel poste um exemplo dos seus arquivos

que ai faço o download e te envio...

Answer 4

 

Boa tarde

Fiz esse arquivo com as informaçoes passadas.

Teste e veja se lhe ajuda para solução do seu problema

caso fique alguma duvida retorne o contato.

 

http://www.4shared.com/file/JCxd5Hws/Frum_Vba.html

abrç

 

Answer 5

Ficou excelente!!

Mas será que é possível fazer pra selecionar mais de um documento no listbox?

Obrigado mesmo pelo esforço em ajudar.

[]'s

Answer 6

Koash

 

Coloque tds seus docs dentro da pasta

e substitua as funçoes por esta.

desta forma ele percorre a pasta procurando doc a doc

e executando a função de leitura dos docs salvando o novo doc como

copia e fechando o atual.

 

Abrç

 

Sub CARREGAR()

Dim arq As String

arq = Dir(ThisWorkbook.Path & "\" & "*.doc")

Do While arq <> ""

Call LerDocumento(ThisWorkbook.Path & "\" & arq, arq)

arq = Dir()

Loop

End Sub

Sub LerDocumento(a As String, b As String)
   
 Application.ScreenUpdating = False
   
    'Declarações
    Dim appWord As Word.Application
    Dim doc As Word.Document
    Dim prg As Word.Paragraph
    Dim rng As Word.Range
   
    Dim doc1 As Word.Document
    Dim prg1 As Word.Paragraph
    Dim rng1 As Word.Range

   
    'A Aplicação é criada aqui:
    Set appWord = CreateObject("Word.Application")
    'A linha abaixo é importante: você deve querer que
    'sua aplicação seja visível na maioria das vezes
    appWord.Visible = True
   
    'Note que, na linha abaixo, foi adicionado um Documento
    'dentro da Aplicação appWord:
    'Doc Modelo
    Set doc = appWord.Documents.Open(a)
    'Novo Documento
    Set doc1 = appWord.Documents.Add
   
   
        Set prg = doc.Paragraphs(1)
        Set prg1 = doc1.Paragraphs(1)
        prg1.Range.Text = prg.Range.Text



'feito com for de 1 ate quantidade de paragrafos do documento
    For i = 2 To doc.Paragraphs.Count
   
        j = doc1.Paragraphs.Count
        Set prg = doc.Paragraphs(i)
        Set prg1 = doc1.Paragraphs(j)
       
        ' Condição Função Explodida
       
        If prg.Range.Text Like "*Função explodida*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
           
            'Escrever até encontrar proximo subtitulo
           
            Do While Left(prg.Range.Text, Len(prg.Range.Text) - 1) <> "Diagrama"
   
                prg1.Range.Text = prg.Range.Text
                i = i + 1
                j = j + 1
               
                Set prg = doc.Paragraphs(i)
                Set prg1 = doc1.Paragraphs(j)
   
            Loop
       
        End If


        ' Condição Entidade Externas
       
        If prg.Range.Text Like "*Entidades externas*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
            'Escrever até encontrar proximo subtitulo

            Do While Left(prg.Range.Text, Len(prg.Range.Text) - 1) <> "Depósito de dados"
   
                prg1.Range.Text = prg.Range.Text
                i = i + 1
                j = j + 1
               
                Set prg = doc.Paragraphs(i)
                Set prg1 = doc1.Paragraphs(j)
   
            Loop
       
        End If


        ' Condição Funçoes Chamadas
       
        If prg.Range.Text Like "*Funções chamadas*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
            'Escrever até o fim do arquivo

                For k = i To doc.Paragraphs.Count
           
                j = doc1.Paragraphs.Count
                Set prg = doc.Paragraphs(k)
                Set prg1 = doc1.Paragraphs(j)
               
                prg1.Range.Text = prg.Range.Text
                k = k + 1
                j = j + 1
               
               
                Next k
                i = k

        End If

       
       
       
    Next i
   
   
    doc.Close
   
    doc1.SaveAs (ThisWorkbook.Path & "\Cópia " & b)
    doc1.Close
    appWord.Visible = False
   
    'Apenas para limpar memória
    Set rng = Nothing
    Set prg = Nothing
    Set doc = Nothing
    Set appWord = Nothing
   
End Sub

Answer 7

Perfeito cara, ficou show de bola!

Se fosse pra fazer salvando o resultado das buscas em um só documento do word , teria que mudar o código inteiro né.

Se você achar fácil e conseguir fazer, eu gostaria.

Obrigado mesmo.

[]'s

Answer 8

Crie um arquivo nessa pasta como

Cópia Modelo.docx

e  substitua as funçoes antiga por estas

que segue abaixoo.

 

Abrç

 

Sub CARREGAR()

Dim arq As String

arq = Dir(ThisWorkbook.Path & "\" & "*.doc")

Do While arq <> ""

If arq <> "Cópia Modelo.docx" Then

Call LerDocumento(ThisWorkbook.Path & "\" & arq)

End If

arq = Dir()

Loop

End Sub

Sub LerDocumento(a As String)
   
 Application.ScreenUpdating = False
   
    'Declarações
    Dim appWord As Word.Application
    Dim doc As Word.Document
    Dim prg As Word.Paragraph
    Dim rng As Word.Range
   
    Dim doc1 As Word.Document
    Dim prg1 As Word.Paragraph
    Dim rng1 As Word.Range

   
    'A Aplicação é criada aqui:
    Set appWord = CreateObject("Word.Application")
    'A linha abaixo é importante: você deve querer que
    'sua aplicação seja visível na maioria das vezes
    appWord.Visible = True
   
    'Note que, na linha abaixo, foi adicionado um Documento
    'dentro da Aplicação appWord:
    'Doc Modelo
    Set doc = appWord.Documents.Open(a)
    'Novo Documento
    Set doc1 = appWord.Documents.Open(ThisWorkbook.Path & "\Cópia Modelo.docx")
   
   
        Set prg = doc.Paragraphs(1)
        Set prg1 = doc1.Paragraphs(doc1.Paragraphs.Count)
        prg1.Range.Text = prg.Range.Text



'feito com for de 1 ate quantidade de paragrafos do documento
    For i = 2 To doc.Paragraphs.Count
   
        j = doc1.Paragraphs.Count
        Set prg = doc.Paragraphs(i)
        Set prg1 = doc1.Paragraphs(j)
       
        ' Condição Função Explodida
       
        If prg.Range.Text Like "*Função explodida*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
           
            'Escrever até encontrar proximo subtitulo
           
            Do While Left(prg.Range.Text, Len(prg.Range.Text) - 1) <> "Diagrama"
   
                prg1.Range.Text = prg.Range.Text
                i = i + 1
                j = j + 1
               
                Set prg = doc.Paragraphs(i)
                Set prg1 = doc1.Paragraphs(j)
   
            Loop
       
        End If


        ' Condição Entidade Externas
       
        If prg.Range.Text Like "*Entidades externas*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
            'Escrever até encontrar proximo subtitulo

            Do While Left(prg.Range.Text, Len(prg.Range.Text) - 1) <> "Depósito de dados"
   
                prg1.Range.Text = prg.Range.Text
                i = i + 1
                j = j + 1
               
                Set prg = doc.Paragraphs(i)
                Set prg1 = doc1.Paragraphs(j)
   
            Loop
       
        End If


        ' Condição Funçoes Chamadas
       
        If prg.Range.Text Like "*Funções chamadas*" Then
       
            prg1.Range.Text = prg.Range.Text
            i = i + 1
            j = j + 1
                   
            Set prg = doc.Paragraphs(i)
            Set prg1 = doc1.Paragraphs(j)
           
            'Escrever até o fim do arquivo

                For k = i To doc.Paragraphs.Count
           
                j = doc1.Paragraphs.Count
                Set prg = doc.Paragraphs(k)
                Set prg1 = doc1.Paragraphs(j)
               
                prg1.Range.Text = prg.Range.Text
                k = k + 1
                j = j + 1
               
               
                Next k
                i = k

        End If

       
       
       
    Next i
   
   
    doc.Close
       
    'Apenas para limpar memória
    Set rng = Nothing
    Set prg = Nothing
    Set doc = Nothing
    Set appWord = Nothing
   
End Sub

Answer 9

Jhonatan,

Muito obrigado!

Ficou do jeito que eu precisava, só acrescentei duas linhas..

    doc1.Close (por que tava dando mensagem que o arquivo Cópia Modelo já estava em uso)

    appWord.Quit (pra fecha os documentos após salvar no Cópia Modelo)

 

Valeu pelo apoio..

[]'s