Boa noite,
Acho que, talvez, você precise de 4 macros:
Azul1 (Formata sequencia azul na planilha azul);
Azul2 (Formata sequencia vermelha na planilha azul);
Vermelho1 (Formata sequencia azul na planilha vermelha);
Vermelho2 (Formata sequencia vermelha na planilha vermelha).
O código do evento "Change" seria algo como:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$AR$3" And [AR3].Value <> "" Then Vermelho1
If Target.Address = "$AR$4" And [AR4].Value <> "" Then Vermelho2
If Target.Address = "$AZ$3" And [AZ3].Value <> "" Then Azul1
If Target.Address = "$AZ$4" And [AZ4].Value <> "" Then Azul2
End Sub
Fiz as macros Azul1 e Azul2, aí é só adaptar as outras:
'Procura a sequencia de "1" e formata para AZUL na planilha AZUL
Sub Azul1()
Dim Intervalo As Range
Dim Coluna1 As Range
Dim Celula As Range
Dim i As Integer
Dim QtdeAzul As Integer
Dim QtdeVermelho As Integer
Dim QtEnc As Integer
Application.ScreenUpdating = False
QtdeAzul = [AM3].Value
Set Intervalo = [BQ5:AN41084]
Set Coluna1 = [AN5:AN41084]
With Intervalo.Font
.ColorIndex = 15
.Bold = False
End With
For Each Celula In Coluna1
Celula.Select
QtEnc = 0
While ActiveCell.Value = 1 And Not Application.Intersect(ActiveCell, Intervalo) Is Nothing
QtEnc = QtEnc + 1
'Como a Coluna de referência está à direita é necessário alterar este trecho do código
'ActiveCell.Offset(-1, -1).Select
'Para
ActiveCell.Offset(-1, 1).Select
'A sintaxe de Offset é a seguinte: Offset(linha, coluna)
'No caso a macro subia uma linha (linha: -1) à esquerda (coluna: -1)
'pois a coluna estava à direita. Como, agora, a coluna está à esquerda
'a macro vai continuar subindo a linha (-1), porém à direita (coluna:1)
Wend
If QtEnc = QtdeAzul Then
For i = 1 To QtdeAzul
'Aqui vai funcionar no sentido inverso, portanto
'ActiveCell.Offset(1, 1).Select
'precisa ser alterado para
ActiveCell.Offset(1, -1).Select
'A constante não é vbazul e sim vbBlue
ActiveCell.Font.Color = vbBlue
ActiveCell.Font.Bold = True
Next
End If
Next
'É recomendável que se ative novamente a atualização de tela
Application.ScreenUpdating = True
End Sub
'Procura a sequencia de "1" e formata para VERMELHO na planilha AZUL
Sub Azul2()
Dim Intervalo As Range
Dim Coluna1 As Range
Dim Celula As Range
Dim i As Integer
Dim QtdeAzul As Integer
Dim QtdeVermelho As Integer
Dim QtEnc As Integer
Application.ScreenUpdating = False
QtdeVermelho = [AM2].Value
Set Intervalo = [BQ5:AN41084]
Set Coluna1 = [AN5:AN41084]
With Intervalo.Font
.ColorIndex = 15
.Bold = False
End With
For Each Celula In Coluna1
Celula.Select
QtEnc = 0
While ActiveCell.Value = 1 And Not Application.Intersect(ActiveCell, Intervalo) Is Nothing
QtEnc = QtEnc + 1
'Aqui o mesmo raciocínio
'ActiveCell.Offset(1, -1).Select
ActiveCell.Offset(1, 1).Select
Wend
If QtEnc = QtdeVermelho Then
For i = 1 To QtdeVermelho
'Idem
'ActiveCell.Offset(-1, 1).Select
ActiveCell.Offset(-1, -1).Select
Application.ScreenUpdating = True
'A constante da cor vermelha é vbRed
ActiveCell.Font.Color = vbRed
ActiveCell.Font.Bold = True
Next
End If
Next
'É recomendável que se ative novamente a atualização de tela
Application.ScreenUpdating = True
End Sub
Só falta acertar os endereços, pois não estou com a planilha aqui, pois era AM2 e AM3 e você colocou, agora, AR3, AR4, AZ3 e AZ4.
Abraço
Postado : 27/01/2012 6:29 pm