none
Percorrer arquivo .doc RRS feed

  • Pergunta

  • 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

    quinta-feira, 22 de setembro de 2011 19:51

Respostas

  •  

    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ç

     

     


    • Editado Jhonatan Franklin sexta-feira, 23 de setembro de 2011 03:03
    • Marcado como Resposta Koash sábado, 1 de outubro de 2011 23:25
    sexta-feira, 23 de setembro de 2011 02:58
  • 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



    • Marcado como Resposta Koash sábado, 1 de outubro de 2011 23:24
    sábado, 1 de outubro de 2011 21:14

Todas as Respostas

  •  

    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ç

     

     


    • Editado Jhonatan Franklin sexta-feira, 23 de setembro de 2011 03:03
    • Marcado como Resposta Koash sábado, 1 de outubro de 2011 23:25
    sexta-feira, 23 de setembro de 2011 02:58
  • 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

     

    sábado, 24 de setembro de 2011 00:19
  • Koah

     

    Se possivel poste um exemplo dos seus arquivos

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

    terça-feira, 27 de setembro de 2011 21:59
  •  

    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ç

     

    sábado, 1 de outubro de 2011 17:14
  • Ficou excelente!!

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

    Obrigado mesmo pelo esforço em ajudar.

    []'s

    sábado, 1 de outubro de 2011 17:35
  • 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



    • Marcado como Resposta Koash sábado, 1 de outubro de 2011 23:24
    sábado, 1 de outubro de 2011 21:14
  • 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

    sábado, 1 de outubro de 2011 23:24
  • 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



    terça-feira, 4 de outubro de 2011 00:59
  • 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

     

    terça-feira, 4 de outubro de 2011 21:29