Notifications
Clear all

Adaptar Código Copiar Planilha

3 Posts
2 Usuários
0 Reactions
719 Visualizações
(@romanholi)
Posts: 0
New Member
Topic starter
 

Pessoal, boa tarde!

Preciso de mais uma ajuda de vocês!

O código abaixo copia todas as planilhas de todos os arquivos de uma determinada pasta!

Tem como o Excel entrar nos arquivos e copiar apenas a planilha que estiver ativa! Não quero que ele copie todas as planilhas para dentro do meu arquivo.

Vide código:

Sub Copiar()
    Dim PastaOrigem
    Dim FSO
    Dim Pasta
    Dim SubPasta
    Dim SubPst
    Dim Arquivo
    Dim Ws As Worksheet
    Dim Destino As Workbook
    
    Application.DisplayAlerts = False
    

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        PastaOrigem = .SelectedItems(1)
    End With
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Pasta = FSO.GetFolder(PastaOrigem)
    
    'Abre o arquivo "Base_Geral.xlsx"
    Workbooks.Open ("C:UsersfromanholiDesktopMacro BrunaBase_Geral.xlsx")
    Set Destino = ActiveWorkbook
    
    For Each Arquivo In Pasta.Files
        If LCase(Right(Arquivo.Path, 3)) = "xls" Or LCase(Right(Arquivo.Path, 4)) = "xlsx" Then
            Workbooks.Open Arquivo
                For Each Ws In Worksheets
                 Ws.Copy before:=Destino.Sheets(1)
                Next
            Workbooks(Arquivo.Name).Close
        End If
    Next
    

    
    ListaArquivos PastaOrigem
    
   
    
End Sub

Sub ListaArquivos(ByVal PastaOrigem As String)
    Dim FSO
    Dim Pasta
    Dim SubPasta
    Dim SubPst
    Dim Arquivo
    Dim Wh As Worksheet
  
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Pasta = FSO.GetFolder(PastaOrigem)
    Set SubPasta = Pasta.SubFolders
  
    For Each SubPst In SubPasta
        ListaArquivos SubPst.Path
        For Each Arquivo In SubPst.Files
            If LCase(Right(Arquivo.Path, 3)) = "xls" Or LCase(Right(Arquivo.Path, 4)) = "xlsx" Then
                Workbooks.Open Arquivo
                    For Each Ws In Worksheets
                        Ws.Copy before:=ThisWorkbook.Sheets(1)
                    Next
                Workbooks(Arquivo.Name).Close
            End If
        Next
    Next
End Sub

Muitíssimo Obrigado

 
Postado : 24/08/2016 1:37 pm
(@osvaldomp)
Posts: 857
Prominent Member
 

Experimente substituindo estas linhas

For Each Ws In Worksheets
  Ws.Copy before:=Destino.Sheets(1)
 Next

por esta

ActiveSheet.Copy before:=Destino.Sheets(1)
 
Postado : 24/08/2016 2:39 pm
(@romanholi)
Posts: 0
New Member
Topic starter
 

Osvaldo, bom dia!

Funcionou meu amigo!

Obrigado

 
Postado : 25/08/2016 5:36 am