none
VBA BLOQUEAR CELULAR E LIBERAR CELULAS RRS feed

  • Pergunta

  • Boa Tarde Srs.,

    Gostaria de uma ajuda, Tenho 3 colunas A, B , C

    Na coluna A tenho datas de 01 de Janeiro a 31 de Dezembro..

    Na B tenho status da ordem 1 - Fechado 2 Pendente 3 Aberto

    Na C tenho Ok ou Branco

    Gostaria que a Macro validasse as datas e liberasse as celulas conforme data atual (TODAY () ou HOJE ()).,

    Para eu preencher a coluna B ou C.

    Pois tem umas pessoas aqui no trabalho que querem preencher os dados dias depois..

    Queria que todos preenchessem só na data atual..

    Muito Obrigado.

     

    quarta-feira, 18 de maio de 2011 17:17

Respostas

  • Olá,

    Você poderia usar também:

    Sub LiberaDataAtual()
      Dim ws As Worksheet
      
      Set ws = ActiveSheet
      
      With ws
        .Unprotect
        .Cells.Locked = True
        .Columns("A").Find(CDate(Format(Date, "Short Date"))).Offset(, 1).Resize(, 2).Locked = False
        .Protect
      End With
      
    End Sub

    Nota: sugiro que insira esse código no seu evento Worksheet_Activate.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br
    sexta-feira, 20 de maio de 2011 15:34
    Moderador

Todas as Respostas

  • Marco, Boa tarde!

     

    Não sei se é exatamente isso que você precisa, mas pelo que eu entendi seria algo mais ou menos assim:

     

    Sub DesbloqueiaHoje()
      Dim ContLinhas As Integer 'Contador de Linhas
      
      'Desprotege a planilha
      ActiveSheet.Unprotect
      
      'Procura todas as células até encontrar uma célula vazia na coluna A
      ContLinhas = 1
      While (Range("A" & CStr(ContLinhas)).Text <> "")
      
        'Desbloqueia quando estiver igual a data atual
        If Range("A" & CStr(ContLinhas)).Value = Date Then
          Range("B" & CStr(ContLinhas)).Locked = False
          Range("C" & CStr(ContLinhas)).Locked = False
        Else
          Range("B" & CStr(ContLinhas)).Locked = True
          Range("C" & CStr(ContLinhas)).Locked = True
        End If
        
        'Verifica a próxima linha
        ContLinhas = ContLinhas + 1
      Wend
      
      'Protege a planilha
      ActiveSheet.Protect
    End Sub
    

     

    Qualquer detalhe referente ao código posso esclarecer melhor.

     

    Atenciosamente,

    Bráulio Figueiredo Pinto

    quinta-feira, 19 de maio de 2011 16:33
  • Olá,

    Você poderia usar também:

    Sub LiberaDataAtual()
      Dim ws As Worksheet
      
      Set ws = ActiveSheet
      
      With ws
        .Unprotect
        .Cells.Locked = True
        .Columns("A").Find(CDate(Format(Date, "Short Date"))).Offset(, 1).Resize(, 2).Locked = False
        .Protect
      End With
      
    End Sub

    Nota: sugiro que insira esse código no seu evento Worksheet_Activate.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br
    sexta-feira, 20 de maio de 2011 15:34
    Moderador
  • Ola Pessoal,

        Estou precisando de algo parecido, estou aprendendo a montar um cadastro de clientes e amigos, e quando efetuo o calculo dos anos da pessoa eu gostaria de estar bloqueando para evitar que alguem modifique este campo, tentei usar este metodo conforme segue abaixo, so que esta ocorrendo erro, gostaria da ajuda do pessoal do forum, fico grato a todos, obrg

    If (ResultadoAno >0) Then
        Cadastro.Range("C12") = ResultadoAno
        Cadastro.Range("C12").Select
         Selection.Locked = True
         Selection.FormulaHidden = False
         Contents:=True, Scenarios:=True
    end if

        

    quinta-feira, 8 de junho de 2017 19:45
  • Ola Pessoal,  consegui resolver da seguinte maneira, caso alguem esteja passando pela mesma dificuldade

    'Desproteger o Formulario
    Cadastro.Unprotect Password:=""

    If (ResultadoAno >0) Then
        Cadastro.Range("C12") = ResultadoAno
        Cadastro.Range("C12").Select
         Selection.Locked = True
         Selection.FormulaHidden = False
         Contents:=True, Scenarios:=True
    end if

    'Proteger o Formulario
    Cadastro.protect Password:=""

    abraço a todos


    quinta-feira, 8 de junho de 2017 20:55