Bom dia,
Tenho um código que devolve cores dos Labels em função das datas encontradas na planilha.
São 85 Labels (Label, Label1, Label2, Label3..........)
Para cada um criei o código que passo a citar.
Como são 85 Labels, aparece-me a mensagem "Procedure too large".
Como faço para abreviar o código de forma a que ele corra?
Private Sub verifica_datas()
Set origem = Worksheets("CCT Normal").Range("A2:FG87")
'se ENTREGUE E DEVOLVIDO (BRANCO)
If WorksheetFunction.VLookup(CDbl(Label), origem, 163, False) <> "" Then
Label.BackColor = &H8000000F
End If
'se ENTREGUE MAS NÃO DEVOLVIDO (VERDE)
If WorksheetFunction.VLookup(CDbl(Label), origem, 162, False) >= Date And _
WorksheetFunction.VLookup(CDbl(Label), origem, 163, False) = "" Then
Label.BackColor = &HFF00&
End If
'se ENTREGUE E EXPIRADO (VERMELHO)
If WorksheetFunction.VLookup(CDbl(Label), origem, 162, False) < Date And _
WorksheetFunction.VLookup(CDbl(Label), origem, 163, False) = "" Then
Label.BackColor = &HFF&
End If
If WorksheetFunction.VLookup(CDbl(Label), origem, 7, False) = "" Then
Label.BackColor = &H8000000F
End If
'se ENTREGUE E DEVOLVIDO (BRANCO)
If WorksheetFunction.VLookup(CDbl(Label1), origem, 163, False) <> "" Then
Label1.BackColor = &H8000000F
End If
'se ENTREGUE MAS NÃO DEVOLVIDO (VERDE)
If WorksheetFunction.VLookup(CDbl(Label1), origem, 162, False) >= Date And _
WorksheetFunction.VLookup(CDbl(Label1), origem, 163, False) = "" Then
Label1.BackColor = &HFF00&
End If
'se ENTREGUE E EXPIRADO (VERMELHO)
If WorksheetFunction.VLookup(CDbl(Label1), origem, 162, False) < Date And _
WorksheetFunction.VLookup(CDbl(Label1), origem, 163, False) = "" Then
Label1.BackColor = &HFF&
End If
If WorksheetFunction.VLookup(CDbl(Label1), origem, 7, False) = "" Then
Label1.BackColor = &H8000000F
End If
'se ENTREGUE E DEVOLVIDO (BRANCO)
If WorksheetFunction.VLookup(CDbl(Label2), origem, 163, False) <> "" Then
Label2.BackColor = &H8000000F
End If
'se ENTREGUE MAS NÃO DEVOLVIDO (VERDE)
If WorksheetFunction.VLookup(CDbl(Label2), origem, 162, False) >= Date And _
WorksheetFunction.VLookup(CDbl(Label2), origem, 163, False) = "" Then
Label2.BackColor = &HFF00&
End If
'se ENTREGUE E EXPIRADO (VERMELHO)
If WorksheetFunction.VLookup(CDbl(Label2), origem, 162, False) < Date And _
WorksheetFunction.VLookup(CDbl(Label2), origem, 163, False) = "" Then
Label2.BackColor = &HFF&
End If
If WorksheetFunction.VLookup(CDbl(Label2), origem, 7, False) = "" Then
Label2.BackColor = &H8000000F
End If
Postado : 01/02/2017 4:05 am