none
Como executar macro quando altera o valor de uma célula sem gerar um looping infinito em programação VBA? RRS feed

  • Pergunta

  • Sou leigo em programção VBA porém fiz um programação para salvar um tabela da sheet 1, na sheet 3 e contruir um "banco de dados".

     Minha programação abaixo funciona quando eu mudo o valor da célula C33 ele faz a operação, porém só ocorre quando eu realmente insiro um valor nessa célula se eu atrelar uma fórmula nessa célula ele não opera.

    Eu gostaria que a operação ocorresse quando por exemplo: eu altere o valor da celula H24 e como há uma fórmula vinculada com a C33, por consequencia o valor da C33 altera também porém não faz rodar a operação em VBA.

    Preciso disso pois estou fazendo um hiperlink com um equipamento e tenho apenas um fórmula na célula C33 apenas variando o valor de 0 e 1, eu queria que automaticamente quando a celula C33 tiver com 1 rode a operação.

    Fiz duas programções conforme abaixo:

    A primeira preciso inserir o valor da célula para que ocorra, ele não reconhece se o valor for alterado por uma fórmula (consequência da alteração em outras células).

    Private Sub Worksheet_Change(ByVal Target As Range)
        Dim KeyCells As Range

        ' The variable KeyCells contains the cells that will
        ' cause an alert when they are changed.
        Set KeyCells = Range("C33")

        If Not Application.Intersect(KeyCells, Range(Target.Address)) _
               Is Nothing Then
    Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End Sub

    Eu consegui nessa outra progração, porém também apresenta problema, ele entra em um looping infinito até dar erro. Como poderia fazer para rodar a macro 1 vez quando os valores estiverem iguais, no meu caso o valor varia entre 0 e 1, quando estiver em 1 gostaria que rode uma vez, depois volta para 0 não roda e quando voltar em 1 roda novamente mais somente uma execução.

    Private Sub Worksheet_Calculate()
    Static OldVal1 As Variant
    If Range("C33").Value <> OldVal1 Then
        OldVal1 = Range("H24").Value
        Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End Sub

    quarta-feira, 6 de setembro de 2017 11:58

Respostas

  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    
    If Target.Address = "$H$25" Or Target.Address = "$I$24" Then
    Static OldVal1 As Variant
        OldVal1 = Range("H24").Value
    If Range("C33").Value <> OldVal1 Then
    
        Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End If
    
    
    End Sub
    
    Executa somente quando é selecionada a célula H25 ou a célula I24.

    Anderson Diniz

    • Sugerido como Resposta AndersonFDiniz2 quarta-feira, 6 de setembro de 2017 17:30
    • Marcado como Resposta Simaosimao terça-feira, 12 de setembro de 2017 18:47
    quarta-feira, 6 de setembro de 2017 17:29

Todas as Respostas

  • Private Sub Worksheet_Calculate()
    Static OldVal1 As Variant
        OldVal1 = Range("H24").Value
    If Range("C33").Value <> OldVal1 Then
    
        Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End Sub
    
    


    Anderson Diniz

    • Sugerido como Resposta AndersonFDiniz2 quarta-feira, 6 de setembro de 2017 12:27
    quarta-feira, 6 de setembro de 2017 12:27
  • Talvez eu não tenha descrito direito, pois utilizei essa programção e apresentou a mesma coisa.

    Como poderia fazer para rodar a macro apenas 1 vez quando os valores estiverem diferentes, por exemplo se a celula H24 e C33 forem diferentes roda apenas 1 vez a macro não fique rodando até o valor ficar igual, pois no meu caso vai demorar um pouco para alterar o valor e com isso a tabela é salva muitas vezes ocasionando um debug. Ou seja executa 1 vez quando valores das celulas diferentes, algum tempo depois eles ficaram iguais (nesse momento não executa a macro) posteriormente esse valor ficará diferente novamente (deve executar novamente a macro somente 1 vez), e isso ocorrerá sucessivamente. Há alguma forma de fazer esse tipo de programação?

    quarta-feira, 6 de setembro de 2017 15:02
  • Sub Executar()
    Static OldVal1 As Variant
        OldVal1 = Range("H24").Value
    If Range("C33").Value <> OldVal1 Then
    
        Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End Sub
    

    Precisa deixar o cursor dentro desse código e apertar F5 para executar.



    Anderson Diniz

    • Sugerido como Resposta AndersonFDiniz2 quarta-feira, 6 de setembro de 2017 16:55
    quarta-feira, 6 de setembro de 2017 16:54
  • quarta-feira, 6 de setembro de 2017 17:15
  • quarta-feira, 6 de setembro de 2017 17:16
  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    
    If Target.Address = "$H$25" Or Target.Address = "$I$24" Then
    Static OldVal1 As Variant
        OldVal1 = Range("H24").Value
    If Range("C33").Value <> OldVal1 Then
    
        Application.Goto Reference:="Tab_Ciclo"
        ActiveWindow.SmallScroll Down:=3
        Selection.Copy
        Application.Goto Reference:="A_fim"
        Selection.End(xlUp).Select
        ActiveCell.Offset(1, 0).Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
            , SkipBlanks:=False, Transpose:=False
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Sheets("Sheet1").Select
        ActiveCell.Offset(0, 5).Range("A1").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(1, 0).Range("A1").Select
    End If
    End If
    
    
    End Sub
    
    Executa somente quando é selecionada a célula H25 ou a célula I24.

    Anderson Diniz

    • Sugerido como Resposta AndersonFDiniz2 quarta-feira, 6 de setembro de 2017 17:30
    • Marcado como Resposta Simaosimao terça-feira, 12 de setembro de 2017 18:47
    quarta-feira, 6 de setembro de 2017 17:29
  • Obrigado! Deu certo.
    quarta-feira, 6 de setembro de 2017 17:52
  • Favor marcar como respondido. Obrigado.

    Anderson Diniz

    quarta-feira, 6 de setembro de 2017 17:55
  • Desculpa sou novo, mas acredito que marquei correto agora como resposta.

    Qualquer coisa me avisa

    Ainda nesse mesma programação, estou com outra dificuldade para terminar a programação. Verifiquei que ele só executa programação quando é selecionado a célula H25 e inserido a informação manualmente pelo operador.

    O que preciso fazer é um hyperlink com um outro sistema e assim comunicar a planilha (celula H25) com esse sistema. Já fiz essa comunicação e está funcionando normalmente, porém como o que está na célula H25 é um valor que vem de outro sistema e não há nenhuma ação de selecionar a celula e etc ele não executa a programação. Tem como fazer com que o sistema verifique o valor da célula para executar a programação?

    terça-feira, 12 de setembro de 2017 19:09
  • na verdade estou utilizando um lynk DDE (Dynamic data exchange) e não um hyperlink. 
    terça-feira, 12 de setembro de 2017 19:41
  • Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Range("H25"), Target) Is Nothing Then 
         'CHAME O CÓDIGO AQUI
    End If
    
    End Sub
    SE NÃO DER CERTO, FAVOR ABRIR OUTRA PERGUNTA, POIS NÃO ENTENDO MUITO DESSA PARTE.

    Anderson Diniz

    • Sugerido como Resposta AndersonFDiniz2 terça-feira, 12 de setembro de 2017 19:51
    terça-feira, 12 de setembro de 2017 19:51
  • Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Not Intersect(Range("H25"), Target) Is Nothing Then 
         'CHAME O CÓDIGO AQUI
    End If
    
    End Sub
    SE NÃO DER CERTO, FAVOR ABRIR OUTRA PERGUNTA, POIS NÃO ENTENDO MUITO DESSA PARTE.

    Anderson Diniz

    Boa noite !

    Estou com um problema parecido com o citado acima e talvez consegue me ajudar.

    Tenho uma planilha que controla empréstimos de chaves de salas de aula composta pelas seguintes colunas (data_saída, matricula_saída, data_entrega, matrícula_entrega, status).

    Quando realizo um empréstimo de chave, na coluna (matricula_saída) insiro o registro do funcionário através de uma leitor de código de barras e automaticamente a coluna (status) marcado "ocupado".

    Cada funcionário só pode obter no máximo 3 chaves.

    Quando o funcionário devolve a chave, efetuo novamente a leitura da sua matrícula na coluna (matricula_entrega) e automaticamente o status passa a marcar "Disponível".

    O objetivo do controle é ao inserir o registro do funcionário na coluna (matrícula_saída), uma macro verificará se aquele funcionário ainda pode obter outra chave.

    Seria uma crítica do tipo:

    * ao entrar com a matrícula no campo (matricula_saída), verificar se esta matricula no status "ocupado" já ultrapassou o limite de 3 empréstimo e emitir um alerta impedindo que o mesmo registre outro empréstimo para aquele funcionário.

    Bom espero ter conseguido explicar a minha situação.

    Conto com o seu apoio.

    Desde já antecipo os meus agradecimentos.

    Abraço.

    sexta-feira, 2 de março de 2018 00:30