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
Abraço
Marcos Rieper
Curso Excel Completo – Do Básico ao VBA
Quer aprender Excel do Básico, passando pela Avançado e chegando no VBA? Clique na imagem abaixo:
