Notifications

Clear all

Reduzir tamanho da macro

2024 - VBA & Macros

Post Recente por Vkt 6 anos atrás

7 Posts

2 Usuários

0 Reactions

1,930 Visualizações

RSS

Vkt

(@vkt)

Posts: 33

Eminent Member

Topic starter

Pessoal,

Criei um código para formatação condicional.

As células a serem condicionadas funcionam assim:

E4, G4, I4........ATÉ AC4
E6, G6, I6........ATÉ AC6

E vai assim até a linha 72

O código é esse:

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Range("AN4") > 0 Then
        Range("E4").Interior.Color = RGB(153, 255, 51)
        Range("E4").Font.Italic = True
        Range("E4").Font.ColorIndex = 21
        Range("E4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AO4") > 0 Then
        Range("G4").Interior.Color = RGB(153, 255, 51)
        Range("G4").Font.Italic = True
        Range("G4").Font.ColorIndex = 21
        Range("G4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AP4") > 0 Then
        Range("I4").Interior.Color = RGB(153, 255, 51)
        Range("I4").Font.Italic = True
        Range("I4").Font.ColorIndex = 21
        Range("I4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AQ4") > 0 Then
        Range("K4").Interior.Color = RGB(153, 255, 51)
        Range("K4").Font.Italic = True
        Range("K4").Font.ColorIndex = 21
        Range("K4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AR4") > 0 Then
        Range("M4").Interior.Color = RGB(153, 255, 51)
        Range("M4").Font.Italic = True
        Range("M4").Font.ColorIndex = 21
        Range("M4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AS4") > 0 Then
        Range("O4").Interior.Color = RGB(153, 255, 51)
        Range("O4").Font.Italic = True
        Range("O4").Font.ColorIndex = 21
        Range("O4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AT4") > 0 Then
        Range("Q4").Interior.Color = RGB(153, 255, 51)
        Range("Q4").Font.Italic = True
        Range("Q4").Font.ColorIndex = 21
        Range("Q4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AU4") > 0 Then
        Range("S4").Interior.Color = RGB(153, 255, 51)
        Range("S4").Font.Italic = True
        Range("S4").Font.ColorIndex = 21
        Range("S4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AV4") > 0 Then
        Range("U4").Interior.Color = RGB(153, 255, 51)
        Range("U4").Font.Italic = True
        Range("U4").Font.ColorIndex = 21
        Range("U4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AW4") > 0 Then
        Range("W4").Interior.Color = RGB(153, 255, 51)
        Range("W4").Font.Italic = True
        Range("W4").Font.ColorIndex = 21
        Range("W4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AX4") > 0 Then
        Range("Y4").Interior.Color = RGB(153, 255, 51)
        Range("Y4").Font.Italic = True
        Range("Y4").Font.ColorIndex = 21
        Range("Y4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AY4") > 0 Then
        Range("AA4").Interior.Color = RGB(153, 255, 51)
        Range("AA4").Font.Italic = True
        Range("AA4").Font.ColorIndex = 21
        Range("AA4").Font.Underline = xlUnderlineStyleSingle
    End If
    If Range("AZ4") > 0 Then
        Range("AC4").Interior.Color = RGB(153, 255, 51)
        Range("AC4").Font.Italic = True
        Range("AC4").Font.ColorIndex = 21
        Range("AC4").Font.Underline = xlUnderlineStyleSingle
    End If

Acontece que o código está longo demais e para as 72 linhas não funciona.

Gostaria de reduzir o tamanho do código de forma a funcionar corretamente.

Adicionei um anexo para entenderem melhor, mas porque apaguei algumas coisas para diminuir o tamanho da planilha não está funcionando bem.

Postado : 20/09/2018 4:54 pm

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Boa noite!

Veja se este código atende:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    
    For i = 4 To 72 Step 2
        For j = 40 To 52
            If Cells(i, j).Value > 0 Then
                Cells(i, (j - 40) * 2 + 5).Interior.Color = RGB(153, 255, 51)
                Cells(i, (j - 40) * 2 + 5).Font.Italic = True
                Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 21
                Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleSingle
            Else
                Cells(i, (j - 40) * 2 + 5).Interior.Color = 16764057
                Cells(i, (j - 40) * 2 + 5).Font.Italic = False
                Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 0
                Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleNone
            End If
        Next
    Next
End Sub

Talvez no evento Change em vez do SelectionChange funcione melhor:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    
    If Not Application.Intersect(Target, [AN4:AZ72]) Is Nothing Then
        For i = 4 To 72 Step 2
            For j = 40 To 52
                If Cells(i, j).Value > 0 Then
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = RGB(153, 255, 51)
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = True
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 21
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleSingle
                Else
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = 16764057
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = False
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 0
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleNone
                End If
            Next
        Next
    End If
End Sub

Abraço

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 20/09/2018 11:00 pm

Vkt

(@vkt)

Posts: 33

Eminent Member

Topic starter

JValq,

Apresentou esse erro:

Erro em tempo de execução '13':

Tipos incompatíveis

If Cells(i, j).Value > 0 Then

No aguardo!

Postado : 21/09/2018 6:19 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Bom dia!

Se houver valores com erro (#DIV/0, #N/D, por exemplo) nas células a verificação vai falhar.
A instrução On Error Resume Next continua a execução da macro, mesmo com erro:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    
    On Error Resume Next
    If Not Application.Intersect(Target, [AN4:AZ72]) Is Nothing Then
        For i = 4 To 72 Step 2
            For j = 40 To 52
                If Cells(i, j).Value > 0 Then
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = RGB(153, 255, 51)
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = True
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 21
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleSingle
                Else
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = 16764057
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = False
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 0
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleNone
                End If
            Next
        Next
    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    
    On Error Resume Next
    For i = 4 To 72 Step 2
        For j = 40 To 52
            If Cells(i, j).Value > 0 Then
                Cells(i, (j - 40) * 2 + 5).Interior.Color = RGB(153, 255, 51)
                Cells(i, (j - 40) * 2 + 5).Font.Italic = True
                Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 21
                Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleSingle
            Else
                Cells(i, (j - 40) * 2 + 5).Interior.Color = 16764057
                Cells(i, (j - 40) * 2 + 5).Font.Italic = False
                Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 0
                Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleNone
            End If
        Next
    Next
End Sub

Abraço

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 21/09/2018 8:53 am

Vkt

(@vkt)

Posts: 33

Eminent Member

Topic starter

JValq,

Não tinha percebido isso! O exemplo que mandei estava realmente com erro porque precisei apagar as referências.

Confesso que olhei para seu código e pensei: "Como isso pode dar certo? O que são esses cálculos?" Funcionou perfeitamente.

Só para finalizar, você poderia me explicar a lógica por trás disso?

Respondendo ou não o tópico será fechado.

Muito obrigado!

Postado : 21/09/2018 9:28 am

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Veja se os comentários no código ajudam a entender a lógica:

Private Sub Worksheet_Change(ByVal Target As Range)
    'Declaração das variáveis: i (linha) e j (coluna)
    Dim i As Integer
    Dim j As Integer
    
    'Instrução que faz com que a macro continue mesmo que ocorram erros
    On Error Resume Next
    
    'Verifica se a célula alterada (Target) faz parte do intervalo [AN4:AZ72]
    'Se não fizer parte não haverá alterações na formatação do intervalo [E4:AC72]
    If Not Application.Intersect(Target, [AN4:AZ72]) Is Nothing Then
    
        'Laço para percorrer as linhas de 2 em 2 (step) a partir da 4 até a 72
        For i = 4 To 72 Step 2
            
            'Laço para percorrer as colunas 40 (AN) a 52 (AZ)
            For j = 40 To 52
                
                'Desvio condicional para verificar se o valor (intervalo [AN4:AZ72]) é maior que 0
                If Cells(i, j).Value > 0 Then
                    
                    'Caso o valor seja maior que zero aplica a formatação na célula correspondente no intervalo [E4:AC72]
                    'O cálculo (j - 40) * 2 + 5) serve para identificar a coluna correspondente entre os intervalo [AN4:AZ72] e [E4:AC72]
                    'Exemplo: coluna 40 (AN) corresponde à coluna (40 - 40) * 2 + 5 = 5 (coluna E)
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = RGB(153, 255, 51)
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = True
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 21
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleSingle
                Else
                    'Caso contrário aplica a formatação padrão. Serve para quando um valor passa de maior para menor ou igual a zero
                    Cells(i, (j - 40) * 2 + 5).Interior.Color = 16764057
                    Cells(i, (j - 40) * 2 + 5).Font.Italic = False
                    Cells(i, (j - 40) * 2 + 5).Font.ColorIndex = 0
                    Cells(i, (j - 40) * 2 + 5).Font.Underline = xlUnderlineStyleNone
                End If
            Next
        Next
    End If
End Sub

Abraço

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 21/09/2018 1:35 pm