Macro para abrir, copiar e fechar varios arquivos excel na mesma pasta

[ffialho]

Pessoal,

Ja aprendi a copiar e colar usando VBA quando é de um arquivo A para um Arquivo B. Agora a situacao mudou um pouco.

Tenho uma Planilha chamada Avaliação. Preciso alimentar uma de suas abas com informação de uma serie de arquivos:

Tenho uma pasta chamada Dados Mecanica e la toda semana é disponibilizado um arquivo ex:

Disponibilidade 03_03_2012

Disponibilidade 10_03_2012

Disponibilidade 17_03_2012

No decorrer do ano vamos ter 52 arquivos excel... preciso saber como varrer essa pasta e cada semana que o arquivo for adicionado a macro atualize a aba dentro de Avaliacao com os dados novos. De forma que no fim do ano eu tenha todos os dados de 2012...

De cada arquivo destes eu copio sempre a mesma informacao/range... ( sao 4 ranges distintos, mas estão sempre no mesmo local na planilha )

qq ajuda agradeco

[Patropi]

Boa tarde ffialho

Veja se você consegue adaptar este código para o teu caso:

Sub Importar_XLS()

Dim sPath As String, sName As String, fName As String
Dim r As Long, rTemp As Long
Dim shPadrao As Worksheet

'Para a macro executar mais rápido!
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'A planilha onde serão colados os dados
Set shPadrao = Sheets("Plan1")

'O caminho onde as planilhas que serão lidas estão
sPath = "C:\relatorios\"

'Descubro o nome do primeiro arquivo a ser aberto
sName = Dir(sPath & "*.xl*")

'Faço o loop que le todos os arquivos
Do While sName <> ""

    'Acha a ultima linha utilizada na planilha onde serao colados os dados
    r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row

    'O caminho + o nome do arquivo a ser aberto
    fName = sPath & sName

    'Abro o workbook a ser lido
    Workbooks.Open Filename:=fName, UpdateLinks:=False

    'Descubro sua quantas linhas ele possui
    rTemp = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

    'Colo na planilha principal
    ActiveWorkbook.ActiveSheet.Range("A1:J" & rTemp).Copy shPadrao.Range("A" & r + 1)

    'Fecho o arquivo já lido
    ActiveWorkbook.Close SaveChanges:=False

ScapeB:

    'Atualizo a variavel com funcao DIR() que acha o proximo arquivo nao processado
    sName = Dir()

Loop

On Error GoTo 0

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

Abraço.

[ffialho]

Ola Patropi,

Fiz algum um pouco diferente... Fiz o abaixo para listar todos os arquivos no subdiretório:

Sub ListAllFiles()

On Error Resume Next

Dim fso As Object

Dim strName As String, strDir As String

strDir = ActiveWorkbook.Path

Dim strArr(1 To 65536, 1 To 1) As String, i As Long

Plan8.Range("E2:E65000").ClearContents

Let strName = Dir$(strDir & "\*" & "*.xlsx")

Do While strName <> vbNullString

Let i = i + 1

Let strArr(i, 1) = strDir & "\" & strName

Let strName = Dir$()

Loop

Set fso = CreateObject("Scripting.FileSystemObject")

Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)

Set fso = Nothing

Plan8.Select

If i > 0 Then

Range("E2").Resize(i).Value = strArr

End If

Atualiza_Todos.openAllfilesInALocation

Plan8.Select

End Sub

Private Sub recurseSubFolders(ByRef Folder As Object, ByRef strArr() As String, ByRef i As Long)

Dim SubFolder As Object

Dim strName As String

For Each SubFolder In Folder.SubFolders

Let strName = Dir$(SubFolder.Path & "\*" & "*.xlsx")

Do While strName <> vbNullString

Let i = i + 1

Let strArr(i, 1) = SubFolder.Path & "\" & strName

Let strName = Dir$()

Loop

Call recurseSubFolders(SubFolder, strArr(), i)

Next

End Sub

O resultado é que na minha PLAN 8 sai a listagem de todos os arquivos por subdiretorio:

Ex:

Y:/Empresa/Projetos/Acompanhamento/Dados Mecanica/ arquivo.xlsx

Y:/Empresa/Projetos/Acompanhamento/Dados Mecanica/ arquivo2.xlsx

Y:/Empresa/Projetos/Acompanhamento/Dados Mecanica/ arquivo3.xlsx

Y:/Empresa/Projetos/Acompanhamento/Dados Suprimentos/ arquivo.xlsx

Y:/Empresa/Projetos/Acompanhamento/Dados Suprimentos/ arquivo2.xlsx

O que não estou conseguindo fazer é uma macro para abrir cada um dos arquivos dentro do Diretório: Dados Mecânica e copiar na Planilha Avaliacao, Aba Dados Recebidos Mecanica.

tentei adpatar o abaixo para fazer isso... mas não roda... ele roda todas as subpastas e tudo mais... mas so quero que faca isso na Mecanica...

Sub openAllfilesInALocation()

Application.ScreenUpdating = False

'*** Begin: Clean all data on database preparing them to be updated ***

With Plan3

.Visible = True

.Select

.Range("D3:Z65536").ClearContents

End With

With Plan4

.Visible = True

.Select

.Range("A2:Z65536").ClearContents

End With

With Plan5

.Visible = True

.Select

.Range("A2:Z65536").ClearContents

End With

'*** End: Clean all data on database preparing them to be updated ***

Dim sAPManagerName As String

sAPManagerName = ActiveWorkbook.Name

Dim nFilesQty As Integer

nFilesQty = 0

Dim sAPManager, sAPTemplate, sFalse, sFileName As String, sAP As String

sAPManager = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

sAPTemplate = ActiveWorkbook.Path & "\PA - Modelo.xls"

sFalse = ActiveWorkbook.Path & "\FALSE.xls"

Dim i As Integer, iAPCounter As Integer, wb As Workbook

iAPCounter = Plan6.Range("Aux_APCounter").Value

For i = 2 To iAPCounter

sAP = Plan6.Range("E" & i).Value

If sAP = sAPManager Or sAP = sAPTemplate Or sAP = sFalse Then

GoTo NextFile

End If

Dim lngCounterDBGeneral, lngCounterDBSummary, lngCounterDBMonth As Long

lngCounterDBGeneral = Plan6.Range("Aux_CounterDBGeneral").Value

lngCounterDBSummary = Plan6.Range("Aux_CounterDBSummary").Value

lngCounterDBMonth = Plan6.Range("Aux_CounterDBMonth").Value

'Open each workbook

Set wb = Workbooks.Open(Filename:=sAP)

sFileName = ActiveWorkbook.Name

'*** Begin: Database builder process ***

'*** Copy the action General data from each original Action Plan ***

Workbooks(sFileName).Activate

Worksheets("BD").Visible = True

Worksheets("BD").Select

Range("BD_Geral").Select

Selection.Copy

'*** Paste the copied data in AP Manager General database ***

Workbooks(sAPManagerName).Activate

Worksheets("DB_General").Select

Range("A" & lngCounterDBGeneral).Select

Selection.PasteSpecial Paste:=xlPasteValues

'*** Copy the action Summary data from each original Action Plan ***

Workbooks(sFileName).Activate

Worksheets("BD").Select

Range("BD_ResumoAcaoGanho").Select

Selection.Copy

'*** Paste the copied data in AP Manager Summary database ***

Workbooks(sAPManagerName).Activate

Worksheets("DB_Summary").Select

Range("A" & lngCounterDBSummary).Select

Selection.PasteSpecial Paste:=xlPasteValues

'*** Copy the Goal Deployment data by month from each original Action Plan ***

Workbooks(sFileName).Activate

Worksheets("BD").Select

Range("BD_CronoMeta").Select

Selection.Copy

'*** Paste the copied data in AP Manager Goal Monthly Deployment database ***

Workbooks(sAPManagerName).Activate

Worksheets("DB_Month").Select

Range("A" & lngCounterDBMonth).Select

Selection.PasteSpecial Paste:=xlPasteValues

'*** Paste the copied data in AP Manager Goal Monthly Deployment database ***

'*** End: Database builder process ***

Application.CutCopyMode = False

Application.EnableEvents = False

Workbooks(sFileName).Close savechanges:=False

Application.EnableEvents = True

NextFile:

Next i

Workbooks(sAPManagerName).Activate

Worksheets("DB_General").Select

Range("X2:X" & Plan6.Range("Aux_CounterDBGeneral").Value).Value = 1

Plan3.Visible = False

Plan4.Visible = False

Plan5.Visible = False

ThisWorkbook.RefreshAll

Application.ScreenUpdating = True

End Sub

[Wendell Menezes]

Boa tarde,

Eu prefiro fazer assim, veja se atende sua necessidade:

Sub Abrir_Copiar_Colar()

Dim FSO As Object
Dim Pasta As String
Dim Planilha As Object
Dim OpenBook As String

Set FSO = CreateObject("Scripting.FileSystemObject")
Pasta = "C:\" 'Pasta com as planilhas que serão abertas e copiadas

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

For Each Planilha In FSO.GetFolder(Pasta).Files

If InStr(1, Planilha, ".xls") = 0 Then GoTo PRÓXIMO

Workbooks.Open (Planilha)
OpenBook = ActiveWorkbook.Name

'Seu código para copiar

Windows(ThisWorkbook.Name).Activate

'Seu código para colar

Application.CutCopyMode = False
Workbooks(OpenBook).Close False
PRÓXIMO:
Next

Application.ScreenUpdating = True

MsgBox "Dados Copiados com Sucesso!", vbInformation, "Aviso"

Application.Calculation = xlCalculationAutomatic

End Sub

Abraços

[ffialho]

Wendell, desculpa a demora. Mas funcionou perfeito!!!! Muito 10! Valeu pela força!! Código ficou bem mais simples!

Patropi, valeu pela força! Me ajudou bastante! Ja guardei o código para usar numa nova planilha que estou criando aqui. Show de bola! Valeu

[Flavio Soares]

Caso o autor do tópico necessite, o mesmo será reaberto, para isso deverá entrar em contato com a moderação solicitando o desbloqueio.