Tópicos relacionados a códigos VBA, gravação de macros, etc.
Por Segmar 11 Jan 2019 às 12:35
Membro Novato
Mensagens: 5
Reputação: 0
#40030
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
Por babdallas 11 Jan 2019 às 13:17
Membro 5 Estrelas
Mensagens: 1366
Reputação: 632
#40038
Anexa a planilha. Fica mais fácil para testar e verificar o que pode estar acontecendo.
Avatar do usuário
Por Jimmy 11 Jan 2019 às 23:31
Membro 3 Estrelas
Mensagens: 223
Reputação: 131
#40060
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.php?f=27&t=8586&p=40015#p40015
que acho fundamental que você leia, afinal, mais importante que funcionar, é você entender.


Código: Selecionar todosPrivate 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
Por Segmar 12 Jan 2019 às 11:31
Membro Novato
Mensagens: 5
Reputação: 0
#40062
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.
Avatar do usuário
Por Jimmy 12 Jan 2019 às 14:47
Membro 3 Estrelas
Mensagens: 223
Reputação: 131
#40064
Jimmy escreveu: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?
Avatar do usuário
Por Jimmy 12 Jan 2019 às 15:05
Membro 3 Estrelas
Mensagens: 223
Reputação: 131
#40065
Teste assim:

Código: Selecionar todosPrivate 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
Por Segmar 14 Jan 2019 às 17:31
Membro Novato
Mensagens: 5
Reputação: 0
#40148
Jimmy escreveu:
Jimmy escreveu: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
Por Segmar 14 Jan 2019 às 18:29
Membro Novato
Mensagens: 5
Reputação: 0
#40151
Jimmy escreveu:Teste assim:

Código: Selecionar todosPrivate 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.