Notifications
Clear all

Copiar planilhas de pasta e consolidar no banco de dados

6 Posts
2 Usuários
0 Reactions
2,037 Visualizações
(@belan_)
Posts: 30
Eminent Member
Topic starter
 

Galera, bom dia

alguém para ajudar a seguinte demanda?

1) entrar numa pasta na rede;
2) Abrir cada arquivo da pasta existente na extensão .xls;

3) abrir aba “Query”


4) verificar coluna C, e filtrar apenas células que contém o número “2”, após isso, filtrar coluna D e deixar apenas células que contém o numero “4”. Copiar todo esses resultados
5) Abrir planilha Banco de Dados, selecionar aba “BD”, localizar ultima célula preenchida e pular uma linha, aí sim, colar o texto copiado.

Ja tentei aqui atraves desse codigo aqui, mas ele só consegue trazer os dados de um arquivo da pasta.

Sub consolidaBD()

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("BD")

'O caminho onde as planilhas que serão lidas estão
sPath = "C:UsersmattheusbelanDesktopDemanda Osiel20172-FEBRUARY"

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

'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)
    Cells(Rows.Count, "A").End(xlUp).Select
    Selection.Delete Shift:=xlUp

    '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

Muito obrigado Galera!!!

abraço

 
Postado : 22/06/2017 8:32 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

Leia:
https://www.rondebruin.nl/win/s3/win008.htm
Veja um modelo com Iterface grafica:
https://www.rondebruin.nl/win/addins/rdbmerge.htm

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 22/06/2017 8:55 am
(@belan_)
Posts: 30
Eminent Member
Topic starter
 

Alexandre,
Infelizmente sou muito garoto no mundo VBA, e os links que me passou são muito interessantes, porém ainda acho que o código abaixo necessita apenas de alguns ajustes para rodar 100%.
o que ta ocorrendo nesse código é que ele só traz a primeira planilha da pasta.. sendo que existem mais 7 planilhas na pasta com a extensão .xls

você pode dar uma olhada nesse código?

Sub consolidaBD()

Application.ScreenUpdating = False

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("BD")

'O caminho onde as planilhas que serão lidas estão
sPath = "C:UsersmattheusbelanDesktopDemanda Osiel20172-FEBRUARY"

'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)
    
    'Cells(Rows.Count, "A").End(xlUp).Select
    'Selection.Delete Shift:=xlUp

    '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

Application.ScreenUpdating = True

End Sub

Muito obrigado

 
Postado : 22/06/2017 12:12 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

No meu teste eu não tive problema, isso, se caso eu não tenha entendido.
Dentro de um diretório eu coloquei 15 arquivos com cada guia contendo 24 linhas de 4 colunas.

Após roda o código, veio os dados das guias de cada arquivo.

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 22/06/2017 12:45 pm
(@belan_)
Posts: 30
Eminent Member
Topic starter
 

po, entendi!
o meu infelizmente so ta pegando a primeira planilha da pasta ainda.. to tentando de tudo aqui mas nada!!
Osso..
mas brigadão pela atenção.

abraço

 
Postado : 26/06/2017 6:58 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Boa tarde!!

Você ainda está com problema?

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 13/07/2017 1:04 pm