Boa tarde Trindade,

Dá uma olhada e vê se ajuda.

• Altera a contagem internamente no código;
• Limita a alteração do nome do arquivo;
• Limita a quantidade de vezes que o arquivo pode ser aberto;
• Possibilita a digitação de uma senha para zerar a contagem caso seja atingido o limite...

Resumindo, é isso. A senha é "123"
Não fiz muitos testes...

Qualquer coisa da o grito.
Abraço

Pois é Edson,

Pensei em fazer no registro do Windows, mas bastava abrir a planilha em outra máquina, fora a questão de segurança, não somente do windows como você disse, mas tem a questão do anti vírus também.

Dá uma olhada no último arquivo que postei... Mais algumas maneiras né... Somente para dificultar, pois segurança é complicado.

Trindade, tem como disponibilizar a UDF PreencherZeros()?

Comecei a analisar aqui, mas pode ser que não chegue no resultado correto.

Ela seria algo como:
Format(vDia * vMult & VSenha, Application.WorksheetFunction.Rept(0, 32))
??

Os dias 16 de cada mês do ano de 2016 retornam "0000000", já no ano de 2017 é o dia 17 de cada mês.
Isso se dá pelo fato de que o valor atribuído ao "Multiplicador", se resulta da diferença da subtração do dia com o ano (em dois dígitos) e tudo que multiplica por zero, dá zero.

Fora que é muito preenchimento com zeros... Tem conta aí que é preenchida por 16 dígitos por exemplo. Pega a chave do dia 14/05/2016, 15/05/2016 ...

Qualquer coisa da o grito.
Abraço

Boa tarde, Bernardo.

Trindade, tem como disponibilizar a UDF PreencherZeros()?

O código é esse:

' FUNCAO PREENCHER COM ESPACO A ESQUERDA E/OU DIREITA
Function PreencherEspaco(nPar As Variant, nOccurs As Integer, L_R As Boolean) As String

    Dim nSize As Integer
    Dim nParticle As String
    
    Let nSize = Len(Trim(nPar))
    
    ' Informa se será preenchido na frente (LEFT) ou atrás (RIGHT).
    If L_R Then
        Let nParticle = Space(nOccurs - nSize) & Trim(nPar)
    Else
        Let nParticle = Trim(nPar) & Space(nOccurs - nSize)
    End If

    Let PreencherEspaco = nParticle
    
End Function

' FUNCAO PREENCHER COM ZERO A ESQUERDA E/OU DIREITA
Function PreencherZeros(nPar As Variant, nOccurs As Integer, L_R As Boolean) As String

    Let PreencherZeros = Replace(PreencherEspaco(nPar, nOccurs, L_R), " ", "0")
    
End Function

Peguei na internet mas não me lembro o site pra dar os créditos.
Vou baixar seu arquivo para fazer teste, e verificar a questão das datas, conforme falado ...

Bernardo

Fui testar seu arquivo apresentou o seguinte erro:

Trindade, como disse lá rm cima...

Você terá que "Confiar no acesso ao modelo de objeto do projeto do VBA" dentro da "Central de Confiabilidade".

To no celular, então é bem complicado ajudar muito... Só amanhã de manhã... Kkkkk

Mas é no mesmo lugar onde habilida as macros automaticamente, sem ter a necessidade de habilitar a cada abertura do arquivo. Terá um CheckBox no final. Dá uma olhada lá.

Qualquer coisa da o grito.
Abraço

Pois é Edson,

... Dá uma olhada no último arquivo que postei... Mais algumas maneiras né... Somente para dificultar, pois segurança é complicado...

Essa solução é genial! Muito criativa mesmo, alterando o valor da variável dentro do próprio código "durante o vôo" é show de bola.

Mas que ela também é meio "Frankestein" ah, isso também é, hehehe! . É como um neurologista ficar fazendo uma cirurgia no próprio cérebro, hehehe. O que a gente não se obriga a fazer, tudo em nome da segurança...!

É uma pena que, do lado de lá do teclado o usuário mal-intencionado também use ao máximo sua criatividade, num ciclo sem fim.

Trindade, dá uma olhada.

[EDIT]
Devido a dois históricos de arquivos em anexos inválidos, segue abaixo o código usado.

Option Explicit

Public Function CRIPT(ByVal key As String) As String
Dim i                   As Long
Dim j                   As Long
Dim nChar               As String
Dim vSenha              As String
Dim vConvert            As String
Dim Resto               As Long
Dim RestoCaract         As Long
Dim RestoQualificador1  As Long
Dim RestoQualificador2  As Long
Dim ChaveElevadora      As Long
Dim ChaveMultiplicadora As Long
On Error GoTo zero
    
    RestoCaract = Len(key)
    RestoQualificador1 = RestoCaract Mod 2 + 1
    RestoQualificador2 = RestoCaract Mod 3 + 2
    
    For i = 1 To RestoCaract: nChar = nChar & Asc(Mid(key, i, 1)): Next i
    ChaveElevadora = Application.WorksheetFunction.Max(2, Digito(nChar)) + RestoCaract Mod 11
    ChaveMultiplicadora = Format(Left(ChaveElevadora ^ (RestoQualificador1 * RestoQualificador2), 2), "00")
    
    vConvert = nChar
    For i = 1 To Application.WorksheetFunction.Max(0, 32 - Len(Left(Len(vConvert), 32)))
        vConvert = vConvert & Digito(Mid(vConvert * ChaveMultiplicadora, i, 1))
    Next i
    
    For i = 1 To 32: vSenha = vSenha & Digito(Asc(Mid(vConvert, i, 1)) * ChaveMultiplicadora): Next i
    CRIPT = vSenha
    
    Exit Function
zero:
    CRIPT = "#ERR/CRIPT!"

End Function

Public Function Digito(ByVal nDV As String) As String
Dim nValid  As Variant
Dim nValor  As Variant
Dim i       As Long
Dim DV      As Long
Dim Mult1()
On Error Resume Next

    Mult1 = Array(7, 4, 1, 8, 5, 2, 1, 6, 3, 7, 4)
    nValor = Mid(nDV, 1, Application.CountA(Mult1))
    For i = 1 To Application.CountA(Mult1): DV = DV + Mid(nValor, i, 1) * Mult1(i - 1): Next i

    If DV Mod 11 = 10 Or DV = 0 Then
        Digito = 1
        Else: Digito = DV Mod 11
    End If

End Function

[/EDIT]

Qualquer coisa da o grito.
Abraço

B-A-R-A-L-H-O

Ficou muito top seu código velho.
Vou estudar ele pra tentar implementar na minha aplicação!!
Top, top, top.

E a edição do código automática, conseguiu?