Este fórum está sendo desativado

[carlosm]

Boa Tarde a Todos,

Tenho 2200 ficheiros excel numa mesma pasta de trabalho. Todos são iguais na estrutura e cada um respeita a despesas de uma pessoa.
Quero copiar a área que tem as despesas e colar todas essas 2200 áreas num único ficheiro Excel.
Criei a seguinte macro

" Sub Macro1()
FN = "784.xlsm"
Workbooks.Open "G:\" + FN
Windows(FN).Activate
Sheets("Análise Despesas").Select
Range("A12:H41").Select
Selection.Copy
Windows("Resumo Despesa.xlsm").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("K3").Select
Windows(FN).Activate
Range("A2").Select
Application.CutCopyMode = False
Workbooks(FN).Close SaveChanges:=False
Range("I3").Select
End SUB"

Acontece que para funcionar com 2.200 ficheiros preciso de 2.200 FN.
O VBA diz que não excuta porque excede o limite de instruções.

Não há uma forma de usar loop ou algo semelhante?
Basicamente a instrução seria:
abrir o Workbook que está na pasta G
Selecionar o separador Sheet espcifico das despesas
Copiar a área das despesas
Abrir o Excel que irá receber a informação
Colar neste último os dados das despesas
Fechar
repetir o processo até esgotar os 2.200 ficheiros excel que estão na pasta.

Obrigado pelo contributo
CarlosM

[osvaldomp]

Olá, @carlosm .

Veja se o código abaixo pode lhe ajudar.

Código: Selecionar todos

Sub AbreCopiaArq()
 Dim arq As String, wsD As Worksheet, k As Long
  Set wsD = ActiveSheet
  arq = Dir("G:\*.xlsm")
  Application.ScreenUpdating = False
  Do While arq <> ""
   Workbooks.Open "G:\" & arq
    wsD.Cells(Rows.Count, 1).End(3)(2) = arq
    ActiveWorkbook.Sheets("Análise Despesas").Range("A12:H41").Copy
    wsD.Cells(Rows.Count, 1).End(3)(2).PasteSpecial xlValues
    Application.CutCopyMode = False
   ActiveWorkbook.Close SaveChanges:=False
   arq = Dir
   k = k + 1: If k = 5 Then Exit Sub
  Loop
End Sub

#
obs.
1. o código irá abrir/copiar TODOS os arquivos .xlsm contidos no drive G.
2. o nome de cada arquivo aberto será colocado pelo código na primeira célula vazia da coluna A da planilha destino dos dados,
se não quiser esta ação então exclua ou comente esta linha ~~~> wsD.Cells(Rows.Count, 1).End(3)(2) = arq.
3. ao rodar o código a planilha destino dos dados deverá ser a planilha ativa
4. para efeitos de testes iniciais coloquei um contador "k" para limitar em 5 os arquivos já abertos/copiados; se quiser altere para outro valor; esse valor de "k", se desmembrado em K1 e k2 em duas células da planilha destino, também poderá ser utilizado para processar os 2.200 arquivos em etapas, por exemplo 100 arquivos de cada vez; retorne se houver interesse.
se não quiser esta ação então exclua ou comente esta linha ~~~> k = k + 1: If k = 5 Then Exit Sub.

[osvaldomp]

Olá, @carlosm .

Veja se o código abaixo pode lhe ajudar.

Código: Selecionar todos

Sub AbreCopiaArq()
 Dim arq As String, wsD As Worksheet, k As Long
  Set wsD = ActiveSheet
  arq = Dir("G:\*.xlsm")
  Application.ScreenUpdating = False
  Do While arq <> ""
   Workbooks.Open "G:\" & arq
    wsD.Cells(Rows.Count, 1).End(3)(2) = arq
    ActiveWorkbook.Sheets("Análise Despesas").Range("A12:H41").Copy
    wsD.Cells(Rows.Count, 1).End(3)(2).PasteSpecial xlValues
    Application.CutCopyMode = False
   ActiveWorkbook.Close SaveChanges:=False
   arq = Dir
   k = k + 1: If k = 5 Then Exit Sub
  Loop
End Sub

#
obs.
1. o código irá abrir/copiar TODOS os arquivos .xlsm contidos no drive G.
2. o nome de cada arquivo aberto será colocado pelo código na primeira célula vazia da coluna A da planilha destino dos dados,
se não quiser esta ação então exclua ou comente esta linha ~~~> wsD.Cells(Rows.Count, 1).End(3)(2) = arq.
3. ao rodar o código a planilha destino dos dados deverá ser a planilha ativa.
4. para efeitos de testes iniciais coloquei um contador "k" para limitar em 5 os arquivos já abertos/copiados; se quiser altere para outro valor,
se não quiser esta ação então exclua ou comente esta linha ~~~> k = k + 1: If k = 5 Then Exit Sub.
5. esse valor de "k", se desmembrado em Ki e kf (início e fim) em duas células vazias da planilha destino, poderá ser utilizado para processar os 2.200 arquivos em etapas, por exemplo 100 ou 200 arquivos de cada vez; retorne se houver interesse.