Jump to content

Excel/VBA copiar varias folhas de varios ficheiros


cmanuel
 Share

Recommended Posts

Bom dia agradeço desde já qualquer ajuda sobre este tema:

Tenho varios ficheiros de excel 2003 em varias pastas em que todos os ficheiros contem um folha chamada "Cabimentos".

O que eu queria era como criar uma macro "VBA" que fosse ler a estes ficheiros ler a folha cabimentos da Celula A10:Z999 e depois gravá-se no ficheiro "Resumo" na folha "Cabimentos" a informação copiada.

No ideal seria verificar se a celula A10 estava preenchida com texto e se sim copiar só essas linhas.

juntando tudo na folha "Cabimentos" do ficheiro "Resumo"

De preferência que atualiza-se ao abrir.

Obrigado

Link to comment
Share on other sites

boas noites

amigo manuel, isso é possivel fazer, mas poderá ficar um bocado pesado ou seja o excel poderá demorar um bocado a abrir dependendo da quantidade de ficheiros.

explicar melhor a situação que assim está muito vago, se o valor das celulas A10:Z999 depois de gravar é apagado, ou se na proxima vez comeca a copiar na Z999 ou se são os ficheiros que vão aumentando.

a sugestão seria em vba, criar uma rotina que abra os ficheiros e grave as celulas pretendidas.

para começares podes ver este pequeno enxerto de cod:


On Error Resume Next
Dim fich As New Excel.Application
Dim fichbook As Excel.Workbook
Dim xlSheets As Excel.Worksheet
Dim RangMapDiario As Range
Set fich = CreateObject("Excel.application")
'esta linha abre um arquivo existente sem criar aplicação
Set fichbook = fich.Workbooks.Open(vCaminhoFich)	 '("C:\Users\minhoca\Desktop\DTersPTers(Out).xlsx")
fichbook.Sheets("MAPA DIÁRIO").Select
fichbook.Sheets("MAPA DIÁRIO").Unprotect ("xxxxxxxxxx")
Set xlSheets = fichbook.Sheets("MAPA DIÁRIO")
xlSheets.Range("C7:AG56").Value = ""
Set RangMapDiario = xlSheets.Range("C7:AG56")
Dim vRangDias As Range
Dim vCont As Byte
Dim vContEfectivo As Byte
vCont = 0
For Each vRangDias In vDias.Rows
vCont = vCont + 1
'xlSheets.Range("B5").Select
For vContEfectivo = 1 To vQtdEfectivo
If Trim(vRangDias.Cells(1, 9 + vContEfectivo)) = "/" Or Trim(vRangDias.Cells(1, 9 + vContEfectivo)) = "PRT" Then
RangMapDiario.Cells(vContEfectivo, vCont).Value = "AT"
End If
Next vContEfectivo
Next vRangDias
xlSheets.Range("AF24").Select
vCaminhoFich = Empty
fichbook.Sheets("MAPA DIÁRIO").Protect ("xxxxxxxxxxx")
fichbook.Application.Visible = True
fichbook.Windows(1).Visible = True
Set fichbook = Nothing
Set fich = Nothing

terás que fazer mais ou menos isto para os ficheiros todos:

Dim xl As New Excel.Application
Dim xlw As Excel.Workbook
'o arquivo do Excel
Set xlw = xl.Workbooks.Open("c:\teste\teste.xls")
'definir qual a planilha de trabalho
xlw.Sheets("Plan1").Select
'Exibe o conteúdo da célula na posição A10:Z999")
variavel = xlw.Application.Range("A10:Z999").Value
MsgBox xlw.Application.range("A10:Z999").Value

'Fechar a planilha sem salvar alterações
' Para salvar mude False para True
xlw.Close False

'Liberamos a memória
Set xlw = Nothing
Set xl = Nothing

cumps

acao

Edited by acao
Link to comment
Share on other sites

Antes de mais Obrigado pela resposta.

O objectivo e ter um ficheiro excel em cada pasta e um geral que possa estar atualizado.

No entanto dentro da pasta principal poderão ser criadas subpastas com novos ficheiros excel.

Os ficheiros excel serão sempre iguais em numero de folhas e nome das folhas já o nome do ficheiro será ligeiramente diferente.

A informação a copiar será sempre a partir da linha 10 inclusive no entanto a qualquer altura poderá ser preenchida a linha 11, 12, 13, etc.

Se for possivel actualizar só penso ser melhor, no entanto, se copiar tudo de todos os ficheiros ai terá que apagar no resumo para não duplicar.

o Codigo que já arranjei é este no entanto só copiar de uma morada especifica e duplica a informação.

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

'O caminho onde as planilhas que serão lidas estão
sPath = "D:\Desktop\Guerra\Ano 2012\Geologia Marinha\CIENCIA 2007\"


'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(shPadrao.Cells.Range("A10:CG10000").Rows.Count, "A").End(xlUp).Row
Debug.Print "r=", r
'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
ActiveWorkbook.Sheets("Cabimentos").Activate

rTemp = ActiveWorkbook.ActiveSheet.Cells(ActiveWorkbook.ActiveSheet.Cells.Range("A10:CG10000").Rows.Count, "A").End(xlUp).Row

'Colo na planilha principal
ActiveWorkbook.ActiveSheet.Range("A10:CG" & 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

Obrigado

Edited by apocsantos
Link to comment
Share on other sites

boas

vê este exemplo de listar todos os ficheiros de pastas

http://www.jorgepaulino.com/2008/08/excel-microsoft-scripting-runtime.html

Se for possivel actualizar só penso ser melhor, no entanto, se copiar tudo de todos os ficheiros ai terá que apagar no resumo para não duplicar.

o mais simples seria apagar os valores do ficheiro resumo.

mas sempre podes fazer :

verificar se os valores de cada linha existe no ficheiro resumo utilizando para isso uma coluna que não tenha dados repetidos e utilizando a função «Intersect».

exemplos:

http://www.jorgepaulino.com/2009/09/excel-dicas-de-vba-eventos.html

podes adaptar este exemplo, se reparares ao alterares o valor da coluna G ou H pinta os numeros iguais a essa linha, tu podes fazer o inverso, copias se nao tiver valores iguais.

http://dl.dropbox.com/u/65238129/Pintar_Celulas.xlsm

cumps

acao

Edited by acao
Link to comment
Share on other sites

Bom dia,

Estou um pouco perdido, codigo não é o meu forte.

O codigo que aparece nos links eu não entendo, seria pedir muito indicar onde e o falha no meu codigo. neste momento o que me falha e que na morada que eu dou do "sPath" ele só le os ficheiros excel que estão nessa pasta (sPath = "D:\Desktop\Guerra\Ano 2012\Geologia Marinha\CIENCIA 2007\) se eu alterar a morada da sPath = "D:\Desktop\Guerra\Ano 2012\Geologia Marinha\ ele já não vai ler nas sub pastas.

O que me esta a faltar????

Obrigado um vez mais pela paciencia.

Cumprimentos.

Link to comment
Share on other sites

boas

tens aqui o teu cod colocado no exemplo que te enviei

não te esqueças de fazer referencia a «Microsoft Scripting Runtime» conforme indica o exemplo.

Option Explicit
' Cria uma nova instância do FileSystemObject
Private fso As New FileSystemObject
' Declaração de variáveis
Private sFolder As Scripting.Folder
Private myFile As Scripting.File
Private myFolder As Scripting.Folder
Private pos As Long
Private Sub CommandButton1_Click()
Dim vsPath As String
'caminho para a pasta da sub pasta e ficheiros.
vsPath = "D:\Teste"
Call ShowSubFolderFiles(vsPath)
End Sub
' --------------------------------------------------------------------
' Sub auxiliar que lista os ficheiros nas sub-pastas
' --------------------------------------------------------------------
Sub ShowSubFolderFiles(ByVal folderName As String)
 ' Ignora erros em pastas protegidas, pastas de sistema, etc
On Error Resume Next
Set sFolder = fso.GetFolder(folderName)
Dim sName As String, fName As String
Dim r As Long, rTemp As Long
Dim shPadrao As Worksheet

 ' Ciclo em todas as pastas
For Each myFolder In sFolder.SubFolders
 ' Ciclo em todos os ficheiros
 For Each myFile In myFolder.Files
 fName = myFile.Path


		 'Acha a ultima linha utilizada na planilha onde serao colados os dados
		 r = shPadrao.Cells(shPadrao.Cells.Range("A10:CG10000").Rows.Count, "A").End(xlUp).Row
		 Debug.Print "r=", r
	 '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
		 ActiveWorkbook.Sheets("Cabimentos").Activate
	 rTemp = ActiveWorkbook.ActiveSheet.Cells(ActiveWorkbook.ActiveSheet.Cells.Range("A10:CG10000").Rows.Count, "A").End(xlUp).Row
	 'Colo na planilha principal
	 ActiveWorkbook.ActiveSheet.Range("A10:CG" & rTemp).Copy shPadrao.Range("A" & r + 1)
	 'Fecho o arquivo já lido
	 ActiveWorkbook.Close SaveChanges:=False

Next
' Recursividade: Caso a pasta tenha sub-pastas chama novamente
' o mesmo código - Sub ShowSubFolderFiles()
If myFolder.SubFolders.Count > 0 Then
ShowSubFolderFiles myFolder.Path
End If
Next
On Error GoTo 0
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub

cumps

acao

Edited by apocsantos
Link to comment
Share on other sites

Bom dia,

Fiz referencia a «Microsoft Scripting Runtime» conforme indica o exemplo.

No entanto não aparece nenhuma macro para executar e aparecem umas linhas. (se não aparecer uma imagem aqui foi porque não consegui colocar)

so consigo executar quando o rato esta junto do "Private Sub CommandButton1_Click()" , contudo executa qualquer coisa mas no fim fica tudo igual.

á qualquer coisa que esta faltando.

Mais uma vez Obrigado pelas dicas.

Cump.

Manuel

Edited by cmanuel
Link to comment
Share on other sites

Ok e Obrigado já apliquei o botão para correr.

Problema neste momento é que está a ler PDF e não me os ficheiros excel (*.xls) nem as Folhas e celulas que quero.

abixo envio o ficheiro que estou a usar para mais facil entendimento.

http://www.mediafire.com/view/?3zl1he4r86t8p89

Mais uma vez Obrigado e o meu agradecimento pela paciencia demonstrada.

Cumprimento

Manuel

Edited by cmanuel
Link to comment
Share on other sites

boas

o que eu detectei foi os teus botões estranhos em formato de imagem, elimina-os e insere um botão activex

vais a programador\inserir\controle activex.............e inseres o botão

clikas em modo de estrutura e depois no botão,........abre o cod e acerta o procedimento do botão

colocas breakspoints para verificares o codigo,

desabilita o modo de estrutura e clika no botao.

cumps

acao

Link to comment
Share on other sites

Bom dia

Ok acho que já descobri esses activex e já os apliquei.

Na "sheet 1" colei o codigo adaptei tambem um botão para apagar, até aqui tudo bem quando executo o Botão 1 "Correr" o codigo corre não da erros mas tambem não copia nada.

Lê ficheiros PDF e tudo mas não copia.

O que pretendo era que lêsse só ficheiros *.xls e copiá-se apenas a folha "Cabimentos" da Celula A10:CG999.

Mas isto não acontece.

http://www.mediafire.com/view/?jyb12vf53hf6o9n

Mais uma vez obrigado e não sei o que esta dando errado.

Cumprimentos,

Manuel

Edited by cmanuel
Link to comment
Share on other sites

boas

amigo se não copia é porque o cod que tinha não está correcto, eu não estive a verificar.

para verificar só os ficheiros «xls» podes fazer um if utilizando a função «Right$» e verificar se a variavel «fName» termina em xls.

o cod para copiar já to dei no post 2 é mais ou menos o que lá está, falta gravar a variavel «variavel» na folha , tens que declarar a variavel como range.

tenta fazer se não conseguires apita.

cumps

acao

Edited by acao
Link to comment
Share on other sites

Bom dia,

Passei por aqui para deixar o codigo que estou a usar e que funciona, obrigado.

Sub CopiarDados()
Dim lCount As Long
Dim wbResults As Workbook
Dim CllInicio, CllFim As Range
[A10:CG999].ClearContents
'Para a macro executar mais rápido!
With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
End With

On Error Resume Next
   With Application.FileSearch 'busca as worksheets
   .NewSearch
   .LookIn = "D:\Desktop\" 'no Folder Experiencia
   .Filename = "ORC Desp Rec*.xls" 'nos Files com extensao .xls
   .SearchSubFolders = True  'incluindo Subfolders no Folder Experiencia
    If .Execute > 0 Then  'Se encontrar
	  For lCount = 1 To .FoundFiles.Count
Set wbResults = Workbooks.Open(.FoundFiles(lCount))	  'Abre o Workbook
	    With ActiveWorkbook
		  Worksheets("Cabimentos").Activate 'e activa as Worksheets Cabimentos

		  If Range("A10").Value <> "" Then 'Se a Cell A10 tem dados
Set CllInicio = Range("A10")
Set CllFim = Range("CG999")
		    Range(CllInicio, CllFim).Copy Destination:= _
			  Workbooks("ORC Desp Rec*.xls"). _
			  Worksheets("Cabimentos"). _
			  Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copia para a Workbook Resumo(Sheet1 agora Cabimentos)
		  End If
	    End With
	    If ActiveWorkbook.Name <> "Cabimentos" Then ActiveWorkbook.Close 'Sheet1 agora Cabimentos
	  Next lCount
    End If
   End With
On Error GoTo 0
With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
End With
End Sub

Agora pretendia usar este mesmo codigo e em vez de copiar estas celulas fazer só a soma de uma outra celular, tipo somar o valor de celula A2 em todos os ficheiros para a Celula A2 do resumo.

Cumprimentos,

Obrigado

Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share

×
×
  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.