Sabe depurar codigos?

Se sim vai conseguir identificar a parte do codigo que apaga o dados.

Provalvelmente algo com

clear.contents ou delete no final

É so apagar essa linha do primeiro codigo que vai funcionar.

PS nem olhei os arquivos.

felipen_

Boa tarde!

Segue versão que não apaga os dados do BD e acumla. Pode testar com os mesmos 3 arquivos.

Wagner, bom dia!

Perfeito, deu certo!

Agora uma última macro que eu preciso, com a seguinte lógica:

1) Tenho vários arquivos em Excel em uma determinada pasta.
2) Todos esses arquivos possuem a mesma descrição, mudando apenas uma codificação na descrição e acrescentando no final da descrição se o arquivo está FINALIZADO ou não.
3) Preciso de uma macro que acumule todos os arquivos em um único que estão sem a parte na descrição FINALIZADO.
4) E preciso também de outro arquivo que junte todos os arquivos que estão com o termo FINALIZADO na descrição.

Ou se não em um único banco de dados, o Excel copiar todos os arquivos que estão nesta pasta, finalizados e não finalizados, mas em abas diferentes.

Lembrando que a quantidade das colunas será sempre a mesma.

Segue uma imagem anexada como exemplo e também os arquivos como exemplos.

É possível fazer isso?

Obrigado!

felipen_,

Bom dia!

Para que acumule todos os arquivos em um único que estão sem a parte na descrição FINALIZADO, basta alterar a rotina AbirArquivos desse último arquivo que lhe encaminhei (Arquivo Versão para acumular no BD 2.zip) por este abaixo:

Sub AbrirArquivos()
    '************************************************
    'NECESSITA DA REFERÊNCIA Microsoft Scripting Runtime
    '*********************************************
    'Para inserir a referência, vá ao editor do VBA com ALT + F11
    'Acesse o meu Ferramentas/Referências/Microsoft Scripting Runtime/OK
    
    'Declaração de variáveis
    Dim fso As Scripting.FileSystemObject
    Dim fld As Scripting.Folder
    Dim fl As Scripting.File
    Dim strCaminho As String
    Dim PosiçãoPonto As Long
    
    strCaminho = ActiveWorkbook.Path & ""
    
    'Aqui é criado o objeto que comunica com as pastas do computador
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'Esse objeto executa um método do FileSystemObject
    'para buscar atribuir à variável fld uma pasta
    Set fld = fso.GetFolder(strCaminho)
    
    'Loop em cada elemento (ou seja, arquivo) do caminho desejado:
    For Each fl In fld.Files
        'Verifica se é um arquivo com extensão xlsx
        'ATENÇÂO: No seu código, você pode apagar, na linha abaixo, essa parte: (And Right(fl.Name, 10) <> "lha 1.xlsx" And Right(fl.Name, 10) <> "lha 2.xlsx") _
        isso é porque o meu excel estava com bug pegando dois arquivos inexistentes na pasta
        If Right(fl.Name, 4) = "xlsx" And Right(fl.Name, 10) <> "lha 1.xlsx" And Right(fl.Name, 10) <> "lha 2.xlsx" Then
            PosiçãoPonto = InStrRev(fl.Name, ".", , vbTextCompare) + 1
            If Mid(fl.Name, PosiçãoPonto - 11, 10) <> "Finalizado" Or Mid(fl.Name, PosiçãoPonto - 11, 10) <> "FINALIZADO" Then
                Workbooks.Open strCaminho & (fl.Name)
                'Armazena na variável Global o nome do arquivo
                NomeArquivo = fl.Name
                'Chamar a rotina que copia os arquivos
                Call CopiarArquivo
            End If
        End If
    Next
End Sub

Para que junte todos os arquivos que estão com o termo FINALIZADO na descrição, basta alterar a mesma rotina, em um outro arquivo igual ao Arquivo Versão para acumular no BD 2.zip a rotina abaixo:

Sub AbrirArquivos()
    '*********************************************
    'NECESSITA DA REFERÊNCIA Microsoft Scripting Runtime
    '************************************************
    'Para inserir a referência, vá ao editor do VBA com ALT + F11
    'Acesse o meu Ferramentas/Referências/Microsoft Scripting Runtime/OK
    
    'Declaração de variáveis
    Dim fso As Scripting.FileSystemObject
    Dim fld As Scripting.Folder
    Dim fl As Scripting.File
    Dim strCaminho As String
    Dim PosiçãoPonto As Long
    
    strCaminho = ActiveWorkbook.Path & ""
    
    'Aqui é criado o objeto que comunica com as pastas do computador
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'Esse objeto executa um método do FileSystemObject
    'para buscar atribuir à variável fld uma pasta
    Set fld = fso.GetFolder(strCaminho)
    
    'Loop em cada elemento (ou seja, arquivo) do caminho desejado:
    For Each fl In fld.Files
        'Verifica se é um arquivo com extensão xlsx
        'ATENÇÂO: No seu código, você pode apagar, na linha abaixo, essa parte: (And Right(fl.Name, 10) <> "lha 1.xlsx" And Right(fl.Name, 10) <> "lha 2.xlsx") _
        isso é porque o meu excel estava com bug pegando dois arquivos inexistentes na pasta
        If Right(fl.Name, 4) = "xlsx" And Right(fl.Name, 10) <> "lha 1.xlsx" And Right(fl.Name, 10) <> "lha 2.xlsx" Then
            PosiçãoPonto = InStrRev(fl.Name, ".", , vbTextCompare) + 1
            If Mid(fl.Name, PosiçãoPonto - 11, 10) = "Finalizado" Or Mid(fl.Name, PosiçãoPonto - 11, 10) = "FINALIZADO" Then
                Workbooks.Open strCaminho & (fl.Name)
                'Armazena na variável Global o nome do arquivo
                NomeArquivo = fl.Name
                'Chamar a rotina que copia os arquivos
                Call CopiarArquivo
            End If
        End If
    Next
End Sub

Wagner, bom dia!

Ocorreu um erro, veja na depuração abaixo (imagem).

Será que tem algo relacionado com a quantidade de arquivos? Pois pode ocorrer do Excel ter que abrir mais de 50 arquivos para copiar e colar no banco...

Aqui não deu erro. Que tipo de erro? Com o código em execução (linha amarela em destaque) verifique qual é o valor da variável fl.name.

Wagner, bom dia!

Apareceu a seguinte mensagem: "Erro em tempo de execução '1004': O método 'Open' do objeto 'Workbooks' falhou."

Como eu vejo este valor?

Eu fiz outro teste utiliazando apenas 2 arquivos, um com a descrição FINALIZADO e outro sem este termo no nome do arquivo.

A macro está copiando de ambos, quando na verdade deveria copiar apenas de um deles (sem o termo FINALIZADO ou Finalizado).

Veja no anexo.

Ok.

Veja com essa versão.

Wagner, boa tarde!

Fiz dois testes:

1) Executando a macro deste último arquivo que você enviou em uma pasta com poucos arquivos na minha área de trabalho: funcionou perfeitamente.
2) Executando na pasta original que fica em uma rede, onde tenho 107 arquivos para serem abertos e copiados: ocorreu o problema.

Perguntas:

1) Será que a quantidade de arquivos a serem abertos está afetando a macro?
2) O arquivo necessita seguir algum padrão de descrição, necessitando somente possuir a palavra "FINALIZADO" ou "Finalizado" no final ou eu posso criar qualquer arquivo com qualquer descrição, desde que tenha esta palavra no final?

Talvez o que possa estar acontecendo, é que tenho dois arquivos que mudam a quantidade de caractéres, por exemplo:

"Cadastro de materiais 99-2018 (Nota MT 200002303)"
"Cadastro de materiais 100-2018 (Nota MT 200002318)"

Obrigado!

Boa tarde,

veja se da certo

 If Right(fl.Name, 4) = "xlsx" Then
            PosiçãoPonto = InStrRev(fl.Name, ".", , vbTextCompare) - 1
            If Mid(fl.Name, PosiçãoPonto - 5, 10) <> "Finalizado" Then
            Workbooks.Open strCaminho & (fl.Name)
                'Armazena na variável Global o nome do arquivo
                NomeArquivo = fl.Name
             If Mid(fl.Name, PosiçãoPonto - 5, 10) <> "FINALIZADO" Then
                Workbooks.Open strCaminho & (fl.Name)
                'Armazena na variável Global o nome do arquivo
                NomeArquivo = fl.Name

Att

felipen_,

Respondendo as suas perguntas:
1) Será que a quantidade de arquivos a serem abertos está afetando a macro?
R - Não há qualquer problema quanto a questão de quantidade. Até porque cada arquivo é aberto, copiado e logo em seguida, fechado novamente.
2) O arquivo necessita seguir algum padrão de descrição, necessitando somente possuir a palavra "FINALIZADO" ou "Finalizado" no final ou eu posso criar qualquer arquivo com qualquer descrição, desde que tenha esta palavra no final?
R - No caso dessa última rotina que lhe encaminhei, ela pega apenas os arquivos que não possuem a palavra "Finalizado". Todavia, isso independe de haver ou não a palavra pois o código está tratando isso nessa linha:

If Mid(fl.Name, PosiçãoPonto - 9, 10) <> "Finalizado" Then

Ou seja, todo arquivo com extensão .xlsx e que não tiver a palavra Finalizado no nome será aberto e os dados serão copiados.

Talvez o que possa estar acontecendo, é que tenho dois arquivos que mudam a quantidade de caracteres
R - Não há problema quanto a isso pois a variável PosiçãoPonto armazena o valor da posição do ponto no nome do arquivo para que a função Mid possa pegar os caracteres a partir dessa posição, contar 10 caracteres e ter como retorno a palavra "Finalizado". Assim se MID não retornar "Finalizado" é porque o arquivo precisa ser aberto.

Executando na pasta original que fica em uma rede, onde tenho 107 arquivos para serem abertos e copiados: ocorreu o problema
R - Que problema? Que erro? Onde o código parou?

Talvez o problema esteja acontecendo na linha de comando abaixo:

strCaminho = ActiveWorkbook.Path & ""

Porque? Porque você está executando o arquivo da sua máquina e tentando buscar os arquivos em uma pasta do Servidor na Rede. A linha de comando acima pressupõe que os arquivos a serem lidos estão na mesma pasta onde está o arquivo de macro do Excel que está sendo executado.

Se for isso, para alterar, você deverá modificar essa linha para algo como (de acordo com o caminho da sua rede):

strCaminho =  "U:3 - Ger do Risco de Credito3.2 - Risco de CréditoBalancetesRecentes"

Wagner, boa tarde!

Mesmo copiando a pasta para minha área de trabalho, está ocorrendo o erro das imagens anexo.

Entendi... como me parece que você não sabe depurar o código, infelizmente, só pegando essa pasta com todos os seus arquivos para fazer o teste. Se puder disponibilizar a pasta num servidor de arquivos, disponibilize e cole o link aqui que mais tarde, em casa, eu possa acessar e ver o que há.

Wagner, bom dia!

Talvez acho que descobri o por quê está ocorrendo este erro ao abrir os arquivos.

Alguns dos arquivos que eu abro manualmente, o Excel exibe a seguinte mensagem do anexo.

Isto pode estar atrapalhando a lógica da macro, não pode?

Obrigado!

Entendo...

Tente colocar essa linha de comando antes do comando que chama a rotina que faz a abertura dos arquivos:

Application.DisplayAlerts = False

Depois que o arquivo for fechado, coloque essa outra linha de comando:

Application.DisplayAlerts = True

Se isso não resolver, você pode também enviar um ENTER com o comando sendKeys.