EXCEL - Célula Redundante

[Gibuja]

Pessoal, boa tarde.

 

Estou criando uma rotina do VBA que verifica os dados digitados (linha atual) e dos registros anteriores (linhas acima) e retorna uma cadeia de texto.

 

Entretanto, o excel está retornando que a célula que contém a fórmula criada no VBA é redundante e os valores ficam se alterando a cada nova linha incluída na tabela.

 

Alguém tem uma ideia do que pode estar ocorrendo?

 

Código criado:

Function ajuste(Tabela As Range, TAG As String, TV As String, Status As String) As String    Dim UltimoAjuste As String    Dim LinhaAtual As Double    Dim LinhaAcima As Double    Dim DiferencaData As Double    Dim CalculoData As Double    Dim Contador As Double        LinhaAtual = ActiveCell.Row    LinhaAcima = LinhaAtual - 1    DiferencaData = 720    If TV = "Inicial" Then        If Status = "Aprovado" Then            ajuste = "Manter"        Else            ajuste = "Reduzir"        End If    Else        For Contador = 1 To LinhaAcima        If Tabela.Cells(Contador, 7) = TAG Then            CalculoData = Tabela.Cells(LinhaAtual, 1) - Tabela.Cells(Contador, 1)            If CalculoData < DiferencaData Then               UltimoAjuste = Tabela.Cells(Contador, 19)            End If        End If        Next        If Status = "Aprovado" Then            If UltimoAjuste = "Extender" Then            ajuste = "Extender"            ElseIf UltimoAjuste = "Manter" Then            ajuste = "Extender"            ElseIf UltimoAjuste = "Reduzir" Then            ajuste = "Periodicidade Inicial"            ElseIf UltimoAjuste = "Reduzir ao Máximo" Then            ajuste = "Reduzir"            ElseIf UltimoAjuste = "Periodicidade Inicial" Then            ajuste = "Extender"            End If        ElseIf Status = "Reprovado" Then            If UltimoAjuste = "Extender" Then            ajuste = "Periodicidade Inicial"            ElseIf UltimoAjuste = "Manter" Then            ajuste = "Reduzir"            ElseIf UltimoAjuste = "Reduzir" Then            ajuste = "Reduzir ao Máximo"            ElseIf UltimoAjuste = "Reduzir ao Máximo" Then            ajuste = "Troca de Instrumento"            ElseIf UltimoAjuste = "Periodicidade Inicial" Then            ajuste = "Reduzir"            End If        End If    End IfEnd Function

[Gibuja]

Pessoal, resolvi o problema da seguinte maneira: antes eu havia criado uma função dentro de um módulo. Entretanto, estava dando o problema de redundância, assim, na planilha mesmo criei duas rotinas, uma sendo a função mesmo e outra para chamar a função a cada alteração de uma célula específica.

 

O código ficou assim:

Sub AjustePeriodicidade()    Dim Status As Range    Dim LinhaAtual As Integer    Dim UltimoAjuste As String    Dim LinhaAcima As Integer    Dim DiferencaData As Double    Dim CalculoData As Double    Dim Contador As Double    Dim Ajuste As String    Dim NumeroLinhas As Integer               LinhaAtual = ActiveCell.Row    Set Status = Range("R" & LinhaAtual)    LinhaAcima = LinhaAtual - 1    DiferencaData = 720    Set Tabela = Range("A2:S" & LinhaAcima)    NumeroLinhas = Tabela.Rows.Count    TV = Range("L" & LinhaAtual)    TAG = Range("G" & LinhaAtual)    If TV = "Inicial" Then        If Status = "Aprovado" Then            Ajuste = "Manter"        Else            Ajuste = "Reduzir"        End If    Else        For Contador = 1 To NumeroLinhas            If Tabela.Cells(Contador, 7) = TAG Then                CalculoData = Tabela.Cells(LinhaAtual, 1) - Tabela.Cells(Contador, 1)                If CalculoData < DiferencaData Then                    UltimoAjuste = Tabela.Cells(Contador, 19)                End If            End If        Next Contador        If Status = "Aprovado" Then            If UltimoAjuste = "Extender" Then                Ajuste = "Extender"            ElseIf UltimoAjuste = "Manter" Then                Ajuste = "Extender"            ElseIf UltimoAjuste = "Reduzir" Then                Ajuste = "Periodicidade Inicial"            ElseIf UltimoAjuste = "Reduzir ao Máximo" Then                Ajuste = "Reduzir"            ElseIf UltimoAjuste = "Periodicidade Inicial" Then                Ajuste = "Extender"            End If        ElseIf Status = "Reprovado" Then            If UltimoAjuste = "Extender" Then                Ajuste = "Periodicidade Inicial"            ElseIf UltimoAjuste = "Manter" Then                Ajuste = "Reduzir"            ElseIf UltimoAjuste = "Reduzir" Then                Ajuste = "Reduzir ao Máximo"            ElseIf UltimoAjuste = "Reduzir ao Máximo" Then                Ajuste = "Troca de Instrumento"            ElseIf UltimoAjuste = "Periodicidade Inicial" Then                Ajuste = "Reduzir"            End If        End If    End If    Application.EnableEvents = False    Range("S" & LinhaAtual).Value = Ajuste    Application.EnableEvents = TrueEnd SubPrivate Sub Worksheet_Change(ByVal Target As Range)    Dim CelulaChave As Range    Dim LinhaAtual As Integer          LinhaAtual = ActiveCell.Row        'Celula que sofrerá a alteação    Set CelulaChave = Range("R" & LinhaAtual)        If Not Application.Intersect(CelulaChave, Range(CelulaChave.Address)) Is Nothing Then        ' Código a ser executado a cada alteração do STATUS        Call AjustePeriodicidade    End If    Application.EnableEvents = TrueEnd Sub