[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: 154
Registrado em: Seg Out 24, 2011 1:50 pm

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

Mensagem por Mathmatic » Sex Ago 11, 2017 10:02 pm

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.


att.
Mathmatic / SC

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
Professor
Professor
Mensagens: 432
Registrado em: Qua Mai 06, 2015 7:39 pm

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

Mensagem por srobles » Sáb Ago 12, 2017 6:21 pm

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


Saulo

Remember when you were young?
You shone like the sun.
Shine On You Crazy Diamond


Se suas dúvidas foram esclarecidas, acrescente ao lado do título o texto [RESOLVIDO].

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

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

Mensagem por Mathmatic » Dom Ago 13, 2017 1:59 am

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.


att.
Mathmatic / SC

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