Ir ao conteúdo
Regras do Clube do Hardware

Macro para abrir,alterar cabeçalho e rodapé, proteger, salvar e sair dos vários arquivos doc e docx na pasta/subpastas. ERRO LOOP?

cmalves

Por cmalves
em Microsoft Office e similares

Posts recomendados

cmalves
 

cmalves

Postado
Postado

abrir,alterar cabeçalho e rodapé, proteger, salvar e sair dos vários arquivos doc e docx na pasta/subpastas.

 

Boa tarde

Fiz uma macro no word e fui aperfeiçoando com ajuda de foruns na internet. Então encontrei uma macro que faz LOOP (http://www.biblesupport.com/topic/1633-running-a-macro-on-all-files-in-a-folder/). Mas não consegui adaptar na minha. Gostaria que algum colega expert me ajudasse nesta demanda.

Obs: Sou leigo em VBA, se possível me informar a solução completa. 

Estou enviando também o anexo

Tenham um excelente fim de semana

Grato a Todos

Clovis

 

 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DoLangesNow()
Dim file
Dim path As String
 
' Path to your folder. MY folder is listed below. I bet yours is different.
' make SURE you include the terminating "\"
'YOU MUST EDIT THIS.
path = "C:\CLOVIS\"
 
'Change this file extension to the file you are opening. .htm is listed below. You may have rtf or docx.
'YOU MUST EDIT THIS.
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file
 
' This is the call to the macro you want to run on each file the folder
'YOU MUST EDIT THIS. lange01 is my macro name. You put yours here.
Call Macro4
 
' Saves the file
If ActiveDocument.Saved = False Then ActiveDocument.Save
Application.Quit SaveChanges:=wdPromptToSaveChanges
' set file to next in Dir
file = Dir()
Loop
End Sub
 
Sub Padronizacao()
       If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
With Selection.Find
        .Text = "LOJA MODELO"
        .Replacement.Text = "LOJA DALAS"
.Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub ENDERECO_NEW()
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
         Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find '..................................................10
        .Text = "AVENIDA CANADÁ" '11
        
'2º) DIGITE ENDEREÇO DA NOVA LOJA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        .Replacement.Text = "AVENIDA ESTADOS UNIDOS " '...12
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                      
                        
.Forward = True '..............13
        .Wrap = wdFindContinue '.......14
        .Format = False '..............15
        .MatchCase = False '...........16
        .MatchWholeWord = False '......17
        .MatchWildcards = False '......18
        .MatchSoundsLike = False '.....19
        .MatchAllWordForms = False '...20
    End With '...................................................21
        Selection.Find.Execute Replace:=wdReplaceAll '...........22
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '...........23 adicionado
        End Sub '..............................................................24 adicionado
Sub rodape2()
'
' rodape2 Macro
' cdfdfd
 ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter '......7
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = _
            "Fone:55 (65)1233-5414 - E-mail: virtuas@clovis.gov.br CEP: 78010-200"
        
'3º) DIGITE TELEFONE E E-MAIL DA NOVA LOJA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        .Replacement.Text = "Fone:55 (65)4747-7895 - E-mail: best@clovis.gov.br"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub Macro4()
Call Padronizacao
Call ENDERECO_NEW
Call rodape2
'ActiveDocument.Protect Password:="123", NoReset:=False, Type:=wdAllowOnlyFormFields
'On Error Resume Next
If ActiveDocument.Saved = False Then ActiveDocument.Save
Application.Quit SaveChanges:=wdPromptToSaveChanges
End Sub

ESLOW.rar

Brun00_
 

Brun00_

Postado
Postado

Altere essas duas coisas

 

---------------------------------------

Sub DoLangesNow()
Dim file
Dim path As String
 
' Path to your folder. MY folder is listed below. I bet yours is different.
' make SURE you include the terminating "\"
'YOU MUST EDIT THIS.
path = "C:\CLOVIS\"
 
'Change this file extension to the file you are opening. .htm is listed below. You may have rtf or docx.
'YOU MUST EDIT THIS.
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file
 
' This is the call to the macro you want to run on each file the folder
'YOU MUST EDIT THIS. lange01 is my macro name. You put yours here.
Call Macro4
 
' Saves the file
If ActiveDocument.Saved = False Then ActiveDocument.Save
Application.ActiveDocument.Close SaveChanges:=wdPromptToSaveChanges
' set file to next in Dir
file = Dir()
Loop
End Sub
 
Sub Padronizacao()
       If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
With Selection.Find
        .Text = "LOJA MODELO"
        .Replacement.Text = "LOJA DALAS"
.Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub ENDERECO_NEW()
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
         Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find '..................................................10
        .Text = "AVENIDA CANADÁ" '11
        
'2º) DIGITE ENDEREÇO DA NOVA LOJA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        .Replacement.Text = "AVENIDA ESTADOS UNIDOS " '...12
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                      
                        
.Forward = True '..............13
        .Wrap = wdFindContinue '.......14
        .Format = False '..............15
        .MatchCase = False '...........16
        .MatchWholeWord = False '......17
        .MatchWildcards = False '......18
        .MatchSoundsLike = False '.....19
        .MatchAllWordForms = False '...20
    End With '...................................................21
        Selection.Find.Execute Replace:=wdReplaceAll '...........22
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '...........23 adicionado
        End Sub '..............................................................24 adicionado
Sub rodape2()
'
' rodape2 Macro
' cdfdfd
 ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter '......7
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = _
            "Fone:55 (65)1233-5414 - E-mail: virtuas@clovis.gov.br CEP: 78010-200"
        
'3º) DIGITE TELEFONE E E-MAIL DA NOVA LOJA
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        .Replacement.Text = "Fone:55 (65)4747-7895 - E-mail: best@clovis.gov.br"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub Macro4()
Call Padronizacao
Call ENDERECO_NEW
Call rodape2
'ActiveDocument.Protect Password:="123", NoReset:=False, Type:=wdAllowOnlyFormFields
'On Error Resume Next
'APAGUE ESSAS DUAS LINHAS EM VERMELHO ABAIXO
If ActiveDocument.Saved = False Then ActiveDocument.Save
Application.Quit SaveChanges:=wdPromptToSaveChanges
End Sub
cmalves
 

cmalves

Postado
  • Autor
Postado

Bruno

Funcionou perfeitamente o código que você me enviou. Só para finalizar, é possível inserir algum comando para que a macro faça alterações nas SUB-PASTAS também???

Se for possível, será melhor ainda.

Por enquanto

Muito Obrigado

Clovis

Brun00_
 

Brun00_

Postado
Postado

Veja se funciona

Sub DoLangesNow()Dim fileDim path As StringDim strFolder As StringDim strSubFolder As StringDim strFile As StringDim colSubFolders As New CollectionDim varItem As Variant     strFolder = "C:\CLOVIS\"     strSubFolder = Dir(strFolder & "*", vbDirectory)     Do While Not strSubFolder = ""         Select Case strSubFolder             Case ".", ".."                              Case Else                  colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder         End Select                  strSubFolder = Dir     Loop         For Each varItem In colSubFolders                      strFile = Dir(strFolder & varItem & "*.doc")         Do While strFile <> ""         Set file = Documents.Open(FileName:=strFolder & _                 varItem & "\" & strFile)         Call Macro4         ActiveDocument.Save         ActiveDocument.Close                  strFile = Dir                  Loop         Next varItem End Sub
cmalves
 

cmalves

Postado
  • Autor
Postado

Prezado colega

Primeiramente, boa tarde e uma ótima semana para nós.

Desculpe-me ter demorado responder. O problema é que tentei executar em casa no final de semana e quando a executo, a tela somente pisca, mas não executa nenhuma ação. Então tentei aqui no serviço e acontece a mesma coisa, ou seja, a tela dá uma piscada, mas não faz nenhuma ação e nenhum tipo de erro acontece. Será que falta habilitar algo no Word/macro???

Minha versão do Word é 2007.

Continuo agradecendo me desculpando por estar dando um pouco de trabalho.

No aguardo

CLOVIS

 

Segue script completo

Sub DoLangesNow()

Dim file

Dim path As String

Dim strFolder As String

Dim strSubFolder As String

Dim strFile As String

Dim colSubFolders As New Collection

Dim varItem As Variant

 

     strFolder = "C:\Users\Desktop\Clovis"

 

     strSubFolder = Dir(strFolder & "*", vbDirectory)

     Do While Not strSubFolder = ""

         Select Case strSubFolder

             Case ".", ".."

                

             Case Else

                  colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder

         End Select

       

          strSubFolder = Dir

     Loop

         For Each varItem In colSubFolders

         strFile = Dir(strFolder & varItem & "*.doc")

         Do While strFile <> ""

         Set file = Documents.Open(FileName:=strFolder & _

                 varItem & "\" & strFile)

 

         Call Macro4

 

         ActiveDocument.Save

         ActiveDocument.Close

        

         strFile = Dir

        

         Loop

 

         Next varItem

 End Sub

 

Sub Padronizacao()

       If ActiveWindow.View.SplitSpecial <> wdPaneNone Then

        ActiveWindow.Panes(2).Close

    End If

    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _

        ActivePane.View.Type = wdOutlineView Then

        ActiveWindow.ActivePane.View.Type = wdPrintView

    End If

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader

        Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

With Selection.Find

        .Text = "LOJA MODELO"

        .Replacement.Text = "LOJA DALAS"

.Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

Sub ENDERECO_NEW()

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then

        ActiveWindow.Panes(2).Close

    End If

    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _

        ActivePane.View.Type = wdOutlineView Then

        ActiveWindow.ActivePane.View.Type = wdPrintView

    End If

    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter

         Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find '..................................................10

        .Text = "AVENIDA CANADÁ" '11

       

'2º) DIGITE ENDEREÇO DA NOVA LOJA

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        .Replacement.Text = "AVENIDA ESTADOS UNIDOS " '...12

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

                     

                       

.Forward = True '..............13

        .Wrap = wdFindContinue '.......14

        .Format = False '..............15

        .MatchCase = False '...........16

        .MatchWholeWord = False '......17

        .MatchWildcards = False '......18

        .MatchSoundsLike = False '.....19

        .MatchAllWordForms = False '...20

    End With '...................................................21

        Selection.Find.Execute Replace:=wdReplaceAll '...........22

        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '...........23 adicionado

        End Sub '..............................................................24 adicionado

Sub rodape2()

'

' rodape2 Macro

' cdfdfd

 ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter '......7

    Selection.Find.ClearFormatting

    Selection.Find.Replacement.ClearFormatting

    With Selection.Find

        .Text = _

            "Fone:55 (65)1233-5414 - E-mail: virtuas@clovis.gov.br CEP: 78010-200"

       

'3º) DIGITE TELEFONE E E-MAIL DA NOVA LOJA

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

        .Replacement.Text = "Fone:55 (65)4747-7895 - E-mail: best@clovis.gov.br"

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

       

       

        .Forward = True

        .Wrap = wdFindContinue

        .Format = False

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

    End With

    Selection.Find.Execute Replace:=wdReplaceAll

    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

End Sub

Sub Macro4()

Call Padronizacao

Call ENDERECO_NEW

Call rodape2

'ActiveDocument.Protect Password:="123", NoReset:=False, Type:=wdAllowOnlyFormFields

'On Error Resume Next

'APAGUE ESSAS DUAS LINHAS EM VERMELHO ABAIXO

'If ActiveDocument.Saved = False Then ActiveDocument.Save

'Application.Quit SaveChanges:=wdPromptToSaveChanges

End Sub 

Brun00_
 

Brun00_

Postado
Postado

Qual seu windows? 7? xp?

 

tem certeza que a pasta é essa?

C:\Users\Desktop\Clovis

pois se for no windows 7 não existe esta pasta.

 

só para garantir coloque a pasta CLOVIS dentro do C:\ e troque o     strFolder = "C:\Users\Desktop\Clovis"       para

 

strFolder = "C:\Clovis"

 

falou.

cmalves
 

cmalves

Postado
  • Autor
Postado

Sim 


Windows7 Professional de 32 bits.


Desculpe!


Corrigindo o que já tinha postado, consigo executar normalmente a macro anterior que faz alterações tanto na pasta "C:\CLOVIS" como na pasta "C:\Users\Desktop\Clovis", automaticamente, ou seja, abre cada documento word, faz as devidas alterações e fecha, isto utilizando o penúltimo código, mas não entra nas sub-pastas. 


Já o último código, quando é executado, a tela somente pisca, mas não faz nenhuma  alteração.


Obrigado


Clovis


Arquivado

Este tópico foi arquivado e está fechado para novas respostas.

Ir à lista de tópicos

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...

LANÇAMENTO!

eletronica2025-popup.jpg


CLIQUE AQUI E BAIXE AGORA MESMO!