Vídeo recomendado
https://youtu.be/diWPPPhW-9E

[RESOLVIDO] Data e Horário de Salvamento no Diretório

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
Mathmatic
Manda bem
Manda bem
Mensagens: 184
Registrado em: Seg Out 24, 2011 1:50 pm

[RESOLVIDO] Data e Horário de Salvamento no Diretório

Mensagem por Mathmatic »

Saudações,

a planilha do Link: https://guiadoexcel.com.br/backup-autom ... excel-vba/ faz um Backup automático de arquivos apresentando a Data e Horário que foi executado o Backup (Término) de cada arquivo.

minha necessidade:
preciso acrescentar neste cód. vba da planilha do Link mais um "comando vba" que me apresente (numa nova coluna) a Data e Horário do Salvamento do arquivo na Pasta (diretório).

hoje só consigo ver esta informação se eu abrir a pasta (diretório) onde está o arquivo e então olhar lá a Data e Horário que foi salvo o mesmo.


Resumindo:
acrescentar cód. vba que mostre também para cada arquivo do Backup, a Data e Horário do Salvamento do mesmo na Pasta (diretório).



desde já agradeço pela vossa ajuda.
Editado pela última vez por Mathmatic em Dom Ago 13, 2017 1:54 am, em um total de 1 vez.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


srobles
Jedi
Jedi
Mensagens: 805
Registrado em: Qua Mai 06, 2015 7:39 pm

Re: Data e Horário de Salvamento no Diretório

Mensagem por srobles »

Mathmatic,

Não sei se está utilizando o código do modelo do site na íntegra, mas vamos lá.

No código existente no site :

Código: Selecionar todos

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
Experimente adicionar o que segue abaixo, após a linha Cells(i,5) = Now :

Código: Selecionar todos

   Cells(i,6) = Format(Now, "DD/MM/YYYY") 'Para gravar a data
   Cells(i,7) = Format(Now, "hh:mm:ss") 'Para gravar a hora
Altere as colunas á serem preenchidas conforme sua necessidade.

Abs


Mathmatic
Manda bem
Manda bem
Mensagens: 184
Registrado em: Seg Out 24, 2011 1:50 pm

Re: [RESOLVIDO] Data e Horário de Salvamento no Diretório

Mensagem por Mathmatic »

tópico RESOLVIDO.

Saudações sr. srobles ,

sua idéia foi muito boa.

eu também já havia tido uma idéia parecida com esta sua e apliquei-a.

muito obrigado por sua colaboração e atenção.


abs.


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder