Notifications
Clear all

Como repetir uma macro para vários arquivos

5 Posts
3 Usuários
0 Reactions
942 Visualizações
(@arthurs)
Posts: 40
Eminent Member
Topic starter
 

Boa tarde!

Fiz um macro, e quero que ela se repita em todos os arquivos de uma pasta.

Sub Macro2()
       
    Workbooks.Open filename:= _
        "Z:Projetos451.xlsx"      ' ESTE É O LOCAL E UM ARQUIVO, QUERIA QUE ESTE PROCESSO SE REPETISSE EM TODOS OS ARQUIVOS DESTA PASTA.

    Range("B60").Select
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Range("C62").Select
    Selection.Copy
    Range("C60").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Abertura e fechamento de módulos ( vazio)"
    Range("C62").Select
    Selection.Copy
    Range("C61").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Abertura e fechamento de módulos (carregado)"
    Range("C63").Select
    Selection.Copy
    Range("C62").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "Funcionamento de travas das cabeceiras e centrais (vazio)"
    Range("C63").Select
    ActiveCell.FormulaR1C1 = _
        "Funcionamento de travas das cabeceiras e centrais (carregado)"
    Range("C49").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range("C49:E50").Select
    Selection.Copy
    Range("C51:E72").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("F49:I50").Select
    Selection.Copy
    Range("F51:I72").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("J59").Select
    Selection.AutoFill Destination:=Range("J59:J62"), Type:=xlFillDefault
    Range("J59:J62").Select
    Range("B57:B58").Select
    Selection.AutoFill Destination:=Range("B57:B63"), Type:=xlFillDefault
    Range("B57:B63").Select
    ActiveWorkbook.Save
    ActiveWindow.Close

End Sub

Obrigado!

 
Postado : 09/10/2017 2:57 pm
xlarruda
(@xlarruda)
Posts: 732
Honorable Member
 

Você pode incluir essa macro na sua planilha "Pessoal" ou tabmbém pode estar como "Personal".

Guia Exibição > Reexibir > PERSONAL.XLSB

Insira o código em qualquer módulo (se não houver um, crie ).
Atribua um atalho para essa macro
Volte a ocultar a planilha novamente

salve e feche.

Abra a planilha desejada e execute a macro através do atalho que foi escolhido.

___________________________________________________________________________________________
Se a resposta atendeu sua dúvida, por favor, clique no Gostei e marque o Tópico como [Resolvido].

Att.

André Arruda

 
Postado : 09/10/2017 3:25 pm
(@arthurs)
Posts: 40
Eminent Member
Topic starter
 

xlarruda

Obrigado, porem eu estou precisando de estilo um loop *.xlsx
pois são 500 arquivos e não quero ficar abrindo um por um.

 
Postado : 09/10/2017 3:29 pm
gfranco
(@wzxnet7)
Posts: 653
Honorable Member
 

Bom dia.
Veja se te ajuda.
A única parte que ficou sem entendimento pra mim foi em qual worksheet dos arquivos a macro irá trabalhar então, eu chutei e coloquei no código que é a primeira sheet.
Se não for CORRIJA ISSO!!!

Sub Executar()
On Error GoTo erro_executa
Dim arq() As Variant
Dim wbnew As Workbook, wb As Workbook
Dim wnew As Worksheet
Dim c As String
arq = Application.GetOpenFilename("arquivos do excel (*.xl*),*.xl*", MultiSelect:=True)
Set wb = ThisWorkbook



Application.ScreenUpdating = False


For A = LBound(arq()) To UBound(arq())

arquivoAberto = arq(A)
Application.Workbooks.Open arquivoAberto
Set wbnew = ActiveWorkbook
wbnew.Worksheets(1).Activate 'É aqui que vc vai alterar se for o caso...
Set wnew = ActiveSheet

'-------------------------
 Range("B60").Select
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Range("C62").Select
    Selection.Copy
    Range("C60").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Abertura e fechamento de módulos ( vazio)"
    Range("C62").Select
    Selection.Copy
    Range("C61").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Abertura e fechamento de módulos (carregado)"
    Range("C63").Select
    Selection.Copy
    Range("C62").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "Funcionamento de travas das cabeceiras e centrais (vazio)"
    Range("C63").Select
    ActiveCell.FormulaR1C1 = _
        "Funcionamento de travas das cabeceiras e centrais (carregado)"
    Range("C49").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Range("C49:E50").Select
    Selection.Copy
    Range("C51:E72").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("F49:I50").Select
    Selection.Copy
    Range("F51:I72").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("J59").Select
    Selection.AutoFill Destination:=Range("J59:J62"), Type:=xlFillDefault
    Range("J59:J62").Select
    Range("B57:B58").Select
    Selection.AutoFill Destination:=Range("B57:B63"), Type:=xlFillDefault
    Range("B57:B63").Select
    
'------------------------





Application.DisplayAlerts = False

wbnew.Close True


Application.DisplayAlerts = True

Next A

Application.ScreenUpdating = True


wb.Worksheets(1).Select
MsgBox "Concluído"

Exit Sub
erro_executa:

Application.ScreenUpdating = True
MsgBox "Ocorreu um erro"




End Sub

Resposta útil? Clique na mãozinha ao lado do botão Citar.

 
Postado : 09/10/2017 3:36 pm
(@arthurs)
Posts: 40
Eminent Member
Topic starter
 

wzxnet7

Show!!! Show !!! rodou redondinho muito obrigado mesmo...

só precisei add no começo "Sheets("2ª Etapa").Select" para pegar a planilha correta

Muito Obrigado

 
Postado : 09/10/2017 4:03 pm