Formula com parâmetros para formatação

Question

Boa tarde
A formula utiliza três parâmetros para formatar uma sequencia de números dentro de determinado intervalo, convém informar que pode haver mais de uma sequencia a formatar na coluna de referencia. Uma plan com as informações em:

                                   https://www.sendspace.com/file/42zej2

Grto

Answer 1

Meu caro Anderson Diniz, obrigado pela contribuição. Mas preciso que faça algumas correções no código.

      https://www.sendspace.com/file/trl6l8

Answer 2

Li, reli e testei varias vezes. infelizmente tem essas correções a fazer, agradeço muito se puder fazer a correção.

Answer 3

Não quero ser abusado, pretensioso ou chato, fiz a implementação mas acho que aqui não deu certo não.

    'Procura na coluna F a quantidade de células preenchidas
    For linha2 = 3 To 9
    
    If ThisWorkbook.Sheets("Plan1").Range("F" & linha2).Value = "" Then

Answer 4

Option Explicit

Sub teste()
    
    
    Dim linha As Range
    Dim quadroDeNumeros As Range
    Dim cl As Object
    Dim coluna As Integer
    Dim linhas As Integer
    Dim linha2 As Integer
    Dim linha3 As Integer
    Dim linha4 As Integer
    
    Dim achouNoCabecalho As Boolean
    'Define o intervalo de células do cabeçalho
    Set linha = ThisWorkbook.Sheets("Plan1").Range("K4:AD4")
    'Define o intervalo de células do quadro de números
    Set quadroDeNumeros = ThisWorkbook.Sheets("Plan1").Range("K6:AD27")
    
    'Tira a formatação do quadro de números
    For Each cl In quadroDeNumeros.Cells
        
        cl.Interior.ColorIndex = 2
        cl.Font.ColorIndex = 1
    Next cl
    'Tira a formatação do cabeçalho
    For Each cl In linha.Cells
        
        cl.Interior.ColorIndex = 2
        cl.Font.ColorIndex = 3
    Next cl
    
    
    For Each cl In linha.Cells
        
        
        If cl.Value = ThisWorkbook.Sheets("Plan1").Range("H2").Value Then
            
            'Encontrou o valor correspondente no cabeçalho
            achouNoCabecalho = True
            'Guarda a coluna da célula que contém o valor
            coluna = cl.Column
            'Formata o fundo célula do cabeçalho, se não quiser, apague a linha abaixo
            ThisWorkbook.Sheets("Plan1").Cells(4, coluna).Interior.ColorIndex = 6
            'Formata a cor da fonte célula do cabeçalho, se não quiser, apague a linha abaixo
            ThisWorkbook.Sheets("Plan1").Cells(4, coluna).Font.ColorIndex = 1
            'Depois vou tirar esta linha
            'MsgBox "O valor " & ThisWorkbook.Sheets("Plan1").Range("H2").Value & " foi encontrado na coluna " & cl.Column
            Exit For
        End If
        
    Next cl
    linha4 = 0
    'Procura na coluna F a quantidade de células preenchidas
    For linha2 = 3 To 9
        
        If ThisWorkbook.Sheets("Plan1").Range("F" & linha2).Value = "" Then
            
            Exit For
        End If
        linha4 = linha4 + 1
        
        Next
        
        linha3 = 3
        For linhas = 6 To 27
            If linha3 <= linha4 Then
                If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F" & linha3).Value) Then
                    ' If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 1, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F4").Value) Then
                    '  If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 2, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F5").Value) Then
                    '   If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 3, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F6").Value) Then
                    '  If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 4, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F7").Value) Then
                    '   If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 5, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F8").Value) Then
                    '  If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas + 6, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F9").Value) Then
                    'Encontrou a sequência no quadro de números
                    
                    linha3 = linha3 + 1
                    If linha3 = linha4 Then
                        'Formata o fundo das células
                        ThisWorkbook.Sheets("Plan1").Cells(linhas, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 1, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 2, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 3, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 4, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 5, coluna).Interior.ColorIndex = 3
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 6, coluna).Interior.ColorIndex = 3
                        
                        
                        'Formata a cor da fonte das células
                        ThisWorkbook.Sheets("Plan1").Cells(linhas, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 1, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 2, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 3, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 4, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 5, coluna).Font.ColorIndex = 2
                        ThisWorkbook.Sheets("Plan1").Cells(linhas + 6, coluna).Font.ColorIndex = 2
                    End If
                    'Pula para a linha abaixo da sequência encontrada
                    linhas = linhas + 6
                End If
                
                
            End If
            
            
            '  End If
            
            
            '  End If
            
            
            '     End If
            
            
            '        End If
            
            
            ' End If
            
            
        Next linhas
        
        
        
End Sub

---

Anderson Diniz

Answer 5

Infelizmente não deu certo, vou dá o post por resolvido. Mas quero agradecer muito pela ajuda.

Abs

Answer 6

---

Anderson Diniz

Answer 7

Option Explicit

Sub teste()
    'Esta é a versão final. Favor testar. Se funcionou, favor marcar como resposta
    
    Dim linha As Range
    Dim quadroDeNumeros As Range
    Dim cl As Object
    Dim coluna As Integer
    Dim linhas As Integer
    Dim linha2 As Integer
    Dim linha3 As Integer
    Dim linha4 As Integer
    Dim linhas2 As Integer
    Dim achoucorrespondencia As Boolean
    Dim linhas3 As Integer
    
    achoucorrespondencia = False
    
 '   Dim achouNoCabecalho As Boolean
    'Define o intervalo de células do cabeçalho
    Set linha = ThisWorkbook.Sheets("Plan1").Range("K4:AD4")
    'Define o intervalo de células do quadro de números
    Set quadroDeNumeros = ThisWorkbook.Sheets("Plan1").Range("K6:AD27")
    
    'Tira a formatação do quadro de números
    For Each cl In quadroDeNumeros.Cells
        
        cl.Interior.ColorIndex = 2
        cl.Font.ColorIndex = 1
    Next cl
    'Tira a formatação do cabeçalho
    For Each cl In linha.Cells
        
        cl.Interior.ColorIndex = 2
        cl.Font.ColorIndex = 3
    Next cl
    
    
    For Each cl In linha.Cells
        
        
        If cl.Value = ThisWorkbook.Sheets("Plan1").Range("H2").Value Then
            
            'Encontrou o valor correspondente no cabeçalho
           ' achouNoCabecalho = True
            'Guarda a coluna da célula que contém o valor
            coluna = cl.Column
            'Formata o fundo da célula do cabeçalho, se não quiser, apague a linha abaixo
            ThisWorkbook.Sheets("Plan1").Cells(4, coluna).Interior.ColorIndex = 6
            'Formata a cor da fonte célula do cabeçalho, se não quiser, apague a linha abaixo
            ThisWorkbook.Sheets("Plan1").Cells(4, coluna).Font.ColorIndex = 1
            Exit For
        End If
        
    Next cl
    linha4 = 0
    'Procura na coluna F a quantidade de células preenchidas
    For linha2 = 3 To 9
        
        If ThisWorkbook.Sheets("Plan1").Range("F" & linha2).Value = "" Then
            
            Exit For
        End If
        linha4 = linha4 + 1
        
        Next
        
        
        For linhas = 6 To 27
            linha3 = 3
            linhas2 = linhas
            For linha3 = 3 To linha4 + 2
                
                If CInt(ThisWorkbook.Sheets("Plan1").Cells(linhas2, coluna).Value) = CInt(ThisWorkbook.Sheets("Plan1").Range("F" & linha3).Value) Then
                    'Encontrou a sequência no quadro de números
                    linhas2 = linhas2 + 1
                    If linha3 = linha4 + 2 Then
                        achoucorrespondencia = True
                        Exit For
                    End If
                Else
                    Exit For
                End If
            Next linha3
            If achoucorrespondencia = True Then
                For linhas3 = linhas To linha4 + linhas - 1
                    
                    'Formata o fundo das células
                    ThisWorkbook.Sheets("Plan1").Cells(linhas3, coluna).Interior.ColorIndex = 3
                    'Formata a cor da fonte das células
                    ThisWorkbook.Sheets("Plan1").Cells(linhas3, coluna).Font.ColorIndex = 2
                    
                Next linhas3
                achoucorrespondencia = False
                
                'Pula para a linha abaixo da sequência encontrada
                linhas = linhas + linha4 - 1
            End If
            
            
        Next linhas
        
        
        
End Sub

---

Anderson Diniz

Answer 8

---

Anderson Diniz

Answer 9

---

Anderson Diniz

Answer 10

Bom dia

Voltando ao fórum, percebo que o código sofreu alterações para se adequar ao pedido. Quero confirmar a qualidade e assertividade do Anderson Diniz, ao qual reitero meu agradecimento.

Abraço