none
Formula com parâmetros para formatação RRS feed

  • Pergunta

  • 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

    domingo, 15 de outubro de 2017 14:52

Respostas

  • 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


    • Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:34
    • Não Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:35
    • Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:35
    • Editado AndersonFDiniz2 domingo, 15 de outubro de 2017 21:35
    domingo, 15 de outubro de 2017 19:30

  • Anderson Diniz

    • Marcado como Resposta Angra_rio segunda-feira, 16 de outubro de 2017 08:22
    domingo, 15 de outubro de 2017 22:01

Todas as Respostas

  • 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


    • Editado Angra_rio domingo, 15 de outubro de 2017 18:33
    domingo, 15 de outubro de 2017 18:01
  • Li, reli e testei varias vezes. infelizmente tem essas correções a fazer, agradeço muito se puder fazer a correção.
    domingo, 15 de outubro de 2017 18:40
  • 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

    domingo, 15 de outubro de 2017 19:13
  • 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


    • Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:34
    • Não Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:35
    • Marcado como Resposta Angra_rio domingo, 15 de outubro de 2017 19:35
    • Editado AndersonFDiniz2 domingo, 15 de outubro de 2017 21:35
    domingo, 15 de outubro de 2017 19:30
  • Infelizmente não deu certo, vou dá o post por resolvido. Mas quero agradecer muito pela ajuda.

    Abs

    domingo, 15 de outubro de 2017 19:38

  • Anderson Diniz

    domingo, 15 de outubro de 2017 20:49
  • 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


    domingo, 15 de outubro de 2017 20:59

  • Anderson Diniz

    domingo, 15 de outubro de 2017 21:45

  • Anderson Diniz

    • Marcado como Resposta Angra_rio segunda-feira, 16 de outubro de 2017 08:22
    domingo, 15 de outubro de 2017 22:01
  • 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 

    segunda-feira, 16 de outubro de 2017 08:22