Início » Blog Guia do Excel » Backup automático de arquivos com Excel VBA

Backup automático de arquivos com Excel VBA

Objetivo: Disponibilizar um arquivo Excel que realiza o backup automático de arquivos com Excel VBA.

Esta planilha foi criada pelo meu amigo Edney Nascimento, ao qual agradeço pela colaboração com o site.

O Edney já colaborou enviando mais dois arquivos:

Marcar vários filtros na tabela dinâmica automaticamente – VBA

Excel converter taxa de juros em períodos – Ano para mês, mês para dia…

Caso o leitor queira auxiliar com o crescimento da base de conhecimento da internet em Excel, além de divulgar seus trabalhos, é só enviar um comentário em qualquer página do Guia do Excel, eu leio e respondo todos os comentários que são sempre bem-vindos.

Neste artigo vamos disponibilizar uma planilha Excel que realiza o backup de arquivos, não necessariamente de Excel, copiando de uma pasta para outra.

A interface é a seguinte:

ARQUIVO: Digite aqui o nome do arquivo, inclusive a extensão do mesmo;

DIRETÓRIO DE ORIGEM: Inscreva aqui o diretório aonde o arquivo está armazenado;

DIRETÓRIO DE DESTINO: Digite a pasta aonde será salvo o arquivo, o nome do arquivo salvo será o mesmo;

STATUS: Este campo é preenchido quando o arquivo é copiado ou quando há um erro na cópia do mesmo, este tratamento de erros está em português, facilitando a correção;

TÉRMINO: Data e hora do término da cópia do arquivo, pois irá depender do tamanho do mesmo.

Ao lado da tabela estão dois botões:

GERAR BACKUP: Efetua a cópia dos arquivos que estejam com a descrição do status diferente de OK, ou seja, se houver um erro na primeira tentativa ou estiver em branco a descrição do campo status, os arquivos serão copiados;

LIMPAR: Realiza a limpeza das colunas Status e Término, para que possa ser realizado um novo backup completo dos arquivos.

Abaixo o código VBA que realiza a cópia dos arquivos e a limpeza dos mesmos, e logo abaixo o botão para o download do arquivo Excel.

Sub GerarBackup()
'Macro gravada em 11/06/2015 por Edney Nascimento

On Error Resume Next
'On Error GoTo Erro_GerarBackup
     
     Dim Mensagem As String
     Dim NomeArquivo As String, DiretorioOrigem As String, DiretorioDestino As String
     Dim UltimaLinha As Long
     
     UltimaLinha = ActiveSheet.Cells(1, 1).End(xlDown).Row
     
     'Executa o processo para cada um dos arquivos existentes
     For i = 2 To UltimaLinha
          
          If Range("D" & i).Value  "OK" Then
            'Carrega as informações do arquivo a ser copiado
            NomeArquivo = Cells(i, 1).Text
            DiretorioOrigem = Cells(i, 2).Text & "\"
            DiretorioDestino = Cells(i, 3).Text & "\"
            
            FileCopy DiretorioOrigem & NomeArquivo, DiretorioDestino & NomeArquivo
            
            'Tratamento de erros para verificar se a cópia do arquivo foi executada com sucesso
            Select Case Err.Number
                 Case 0:   'OK
                           Cells(i, 4).Value = "OK"
                           Cells(i, 5).Value = Now
                           
                 Case 53:  'Arquivo não encontrado
                           Cells(i, 4).Value = "ERRO (ARQ. NAO ENCONTRADO)"
                           
                 Case 70:  'Arquivo aberto
                           Cells(i, 4).Value = "ERRO (ARQUIVO ABERTO)"
                           
                 Case 75:  'Acesso não permitido no diretório de destino
                           Cells(i, 4).Value = "ERRO (ACESSO NEGADO)"
                           
                 Case 76:  'Diretório não encontrado
                           Cells(i, 4).Value = "ERRO (PASTA NAO ENCONTRADA)"
                           
                 Case Else:
                           Mensagem = "Arquivo: " & NomeArquivo & vbCrLf & _
                                     "Pasta Origem: " & DiretorioOrigem & vbCrLf & _
                                     "Pasta Destino: " & DiretorioDestino & vbCrLf & _
                                     "Erro: " & Err.Number & " " & Err.Description
                           MsgBox Mensagem, vbExclamation
                           Cells(i, 4).Value = "ERRO"
            
            End Select
            
            'Zera a variável antes de iniciar a cópia do próximo arquivo
            Err.Number = 0
        End If
               
     Next i
     
     
Fim:
     Exit Sub


Erro_GerarBackup:
     
     Mensagem = Err.Number & " " & Err.Description
     MsgBox Mensagem
     
End Sub

Sub lsLimpar()
    Dim lUltimaLinhaAtiva As Long
    
    lUltimaLinhaAtiva = Worksheets("Backup").Cells(Worksheets("Backup").Rows.Count, 1).End(xlUp).Row
    
    Range("D2:E" & lUltimaLinhaAtiva).Clear
    
End Sub