Este fórum está sendo desativado

[Segmar]

Bom dia Galera,

Estou precisando de um ajuda com a seguinte situação, tenho uma planilha em que preciso inserir os dados e em seguida impedir que o mesmo seja alterado, isso eu conseguir com o código abaixo, logo após inserir algum dado na célula que faz parte do intervalo (Coluna B) definido no código ela fica bloqueada:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ColunasB As Range
Set ColunasB = Range("B6:B1000")
If Not Application.Intersect(ColunasB, Range(Target.Address)) Is Nothing Then
ActiveSheet.Unprotect ("123")
linha = Target.Row
Range("B" & linha).Locked = True
ActiveSheet.Protect ("123"), DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
End Sub

Preciso também que seja registrada a data que esse dado foi inserido na célula que faz parte do intervalo, isso também eu consigo com o código abaixo:

Dim limite_maximo As Integer
limite_maximo = 1000 ' altere aqui para limitar a última linha
If Alvo.Cells.Count > 1 Or IsEmpty(Alvo) Then Exit Sub
' faz nada se mais de uma célula modificada ou se deu delete
If Alvo.Column <= 2 And Alvo.Row >= 2 And Alvo.Row <= limite_maximo Then
' o if acima garante que a célula modificada está dentro do intervalo definido: A1:Z1000
' desliga captura do evento change
Application.EnableEvents = False
' muda a célula C da linha correspondente
Alvo.Offset(0, 1).Value = Date 'Troque por Date() se quiser que mostre a data ao invés do horário
' religa a captura de eventos
Application.EnableEvents = True
End If

Usados individualmente os dois códigos rodam de boa, mas quando tento utilizar os dois, o registro da alteração é feita, porém todas as células do intervalo já ficam bloqueadas, mesmo as que não inserir nada ainda.

Espero ter conseguindo ser claro, e que possam me ajudar com essa situação, desde já agradeço.

abaixo segue como estou colocando os dois códigos juntos:

Private Sub Worksheet_Change(ByVal Alvo As Range)

Dim ColunasB As Range
Set ColunasB = Range("B6:B1000")
If Not Application.Intersect(ColunasB, Range(Alvo.Address)) Is Nothing Then
ActiveSheet.Unprotect ("123")
linha = Alvo.Row
Range("B" & linha).Locked = True
ActiveSheet.Protect ("123"), DrawingObjects:=True, Contents:=True, Scenarios:=True
End If


Dim limite_maximo As Integer
limite_maximo = 1000 ' altere aqui para limitar a última linha
If Alvo.Cells.Count > 1 Or IsEmpty(Alvo) Then Exit Sub
' faz nada se mais de uma célula modificada ou se deu delete
If Alvo.Column <= 2 And Alvo.Row >= 2 And Alvo.Row <= limite_maximo Then
' o if acima garante que a célula modificada está dentro do intervalo definido: A1:Z1000
' desliga captura do evento change
Application.EnableEvents = False
' muda a célula C da linha correspondente
Alvo.Offset(0, 1).Value = Date 'Troque por Date() se quiser que mostre a data ao invés do horário
' religa a captura de eventos
Application.EnableEvents = True
End If



End Sub

[babdallas]

Anexa a planilha. Fica mais fácil para testar e verificar o que pode estar acontecendo.

[Segmar]

Pronto, o código com problema está na planilha saída.

[Jimmy]

Segmar,

Alterei sua SUB e parece estar funionando.

Não entendi a linha
If Cel.Column <= 2 And Cel.Row >= 2 And Cel.Row <= limite_maximo Then
Uma vez que já está restringindo o Range de atuação lá no Intersect, porque verificar coluna e linhas?

Sua SUB tem algumas características que eu julgo inadequadas, e que alterei na versão abaixo.

Elas estão relatadas no tópico
http://gurudoexcel.com/forum/viewtopic. ... 015#p40015
que acho fundamental que você leia, afinal, mais importante que funcionar, é você entender.

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ColunasB As Range, Cel As Range
    Set ColunasB = Range("B6:B1000")
    Set Inter = Application.Intersect(ColunasB, Range(Target.Address))
    If Not Inter Is Nothing Then
        ActiveSheet.Unprotect ("123")
        For Each Cel In Inter
            linha = Cel.Row
            Range("B" & linha).Locked = True
            ActiveSheet.Protect ("123"), DrawingObjects:=True, Contents:=True, Scenarios:=True
    
            Dim limite_maximo As Integer
            limite_maximo = 1000 ' altere aqui para limitar a última linha
            If Not IsEmpty(Cel) Then
                ' faz nada se deu delete
                If Cel.Column <= 2 And Cel.Row >= 2 And Cel.Row <= limite_maximo Then
                    ' o if acima garante que a célula modificada está dentro do intervalo definido: A1:Z1000
                    ' muda a célula C da linha correspondente
                    Cel.Offset(0, 1).Value = Date 'Troque por Date() se quiser que mostre a data ao invés do horário
                End If
            End If
        Next
    End If
End Sub

Jimmy San Juan

[Segmar]

Bom dia, Jimmy

Muito obrigado pelas dicas, testei o código que me enviou mas ainda não está funcionando, veja que ao digitar alguma coisa na coluna código, na célula B8 por exemplo, ela fica bloqueada para edição, o problema é que todas as células abaixo dela também estão sendo bloqueadas. Quando uso o código só com essa finalidade ele funciona, o problema é quando acrescento a segunda parte, que faz o registro dessa alteração na coluna Data de Saída. Quero fazer com que ele registre a data em que o código foi inserido e depois bloqueie a alteração somente dessa célula.

[Jimmy]

Não entendi a linha
If Cel.Column <= 2 And Cel.Row >= 2 And Cel.Row <= limite_maximo Then
Uma vez que já está restringindo o Range de atuação lá no Intersect, porque verificar coluna e linhas?

Em seu comentário na macro está escrito:
' o if acima garante que a célula modificada está dentro do intervalo definido: A1:Z1000
Poderia esclarecer isso?

[Jimmy]

Teste assim:

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ColunasB As Range, Cel As Range
    Set ColunasB = Range("B6:B1000")
    Set Inter = Application.Intersect(ColunasB, Range(Target.Address))
    If Not Inter Is Nothing Then
        For Each Cel In Inter
            If Not IsEmpty(Cel) Then
                ActiveSheet.Unprotect ("123")
                Cel.Locked = True
                Cel.Offset(0, 1).Value = Date  'Ou NOW() se quiser que mostre também o horário
                Cel.Offset(0, 1).Locked
                ActiveSheet.Protect ("123"), DrawingObjects:=True, Contents:=True, Scenarios:=True
            End If
        Next
    End If
End Sub

[Segmar]

Não entendi a linha
If Cel.Column <= 2 And Cel.Row >= 2 And Cel.Row <= limite_maximo Then
Uma vez que já está restringindo o Range de atuação lá no Intersect, porque verificar coluna e linhas?

Em seu comentário na macro está escrito:
' o if acima garante que a célula modificada está dentro do intervalo definido: A1:Z1000
Poderia esclarecer isso?

Boa tarde Jimmy,

Na verdade eu estou começando a usar o Excel VBA agora, peguei esse código em um outro site de ajuda, fiz até algumas alterações nele, mas não apaguei os comentários, segue o link do código original para que te ajude a entender melhor: https://www.aprenderexcel.com.br/2013/v ... a-no-excel

[Segmar]

Teste assim:

Código: Selecionar todos

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ColunasB As Range, Cel As Range
    Set ColunasB = Range("B6:B1000")
    Set Inter = Application.Intersect(ColunasB, Range(Target.Address))
    If Not Inter Is Nothing Then
        For Each Cel In Inter
            If Not IsEmpty(Cel) Then
                ActiveSheet.Unprotect ("123")
                Cel.Locked = True
                Cel.Offset(0, 1).Value = Date  'Ou NOW() se quiser que mostre também o horário
                Cel.Offset(0, 1).Locked
                ActiveSheet.Protect ("123"), DrawingObjects:=True, Contents:=True, Scenarios:=True
            End If
        Next
    End If
End Sub

Boa tarde, Jimmy

Cara, muito obrigado pela ajuda, descobrir que o problema não está necessariamente nos códigos, todos funcionaram inclusive o meu. O problema é que para funcionar as células precisam estar desbloqueadas, dai a medida que vamos digitando elas vão sendo bloqueadas, é um simples detalhe que eu não prestei atenção.

Obs. Esse último código que enviou ficou melhor porque ficou mais enxuto, mas para funcionar tive que excluir essa linha (Cel.Offset(0, 1).Locked), não sei exatamente a função dela, mas com ela não funciona.

E mais uma vez, muito obrigado.