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