Notifications
Clear all

Agenda para Consultório

26 Posts
3 Usuários
0 Reactions
2,695 Visualizações
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Cells.Interior.Color = RGB(255, 255, 255)
Rows(Target.Row).Interior.Color = RGB(200, 250, 250)
Columns(Target.Column).Interior.Color = RGB(200, 250, 250)
Cells.Borders.ColorIndex = 15
End Sub

Este código acima colore TODA a linha e TODA a coluna da célula ativa!!
.
Mas gostaria que ele colorisse somente ATÉ a célula ativa ... ou seja ... se a célula ativa é G10, SOMENTE a linha ATÉ G e a coluna até 10 ficassem coloridas!!
.
Alguém dá uma luz?? ... Desde já agradeço!!

A intenção é esta, montar uma agenda para o consultório de uma amiga!!

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

 
Postado : 28/05/2016 9:27 am
(@osvaldomp)
Posts: 860
Prominent Member
 

No post anterior sairam 2 códigos, o segundo está comentado, não use. O que vale é este abaixo.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
    Dim RngRow          As Range
    Dim RngCol          As Range
    Dim RngFinal        As Range
    Dim Row             As Long
    Dim Col             As Long

    If Target.Column < 3 Or Target.Column > 29 Then Exit Sub
    If Target.Row < 3 Then Exit Sub

    cor1 = 4
    cor2 = 4
    cor3 = 4

    Range("C3:AC1800").Interior.ColorIndex = xlNone

    Row = Target.Row
    Col = Target.Column
    Set RngRow = Range("C" & Row, Target)
    Set RngCol = Range(Cells(2, Col), Target)
    Set RngFinal = Union(RngRow, RngCol)
   
    RngFinal.Interior.ColorIndex = 6
   
End Sub

Osvaldo

 
Postado : 28/05/2016 9:02 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

.
Sei ... já tinha apagado!!

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

 
Postado : 28/05/2016 9:15 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Copa, a rotina que o Osvaldo indicou, apliquei em seu modelo, e a formatação da cor não ocorre na Linha 1 e nem nas Colunas A e B, e tambem nas linhas cinzas que estão com "Formatação Condicional.
Então, se ainda não é isto oque quer, não entendi.

[]s

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

 
Postado : 28/05/2016 9:38 pm
(@osvaldomp)
Posts: 860
Prominent Member
 

Veja este simplificado. A diferença de funcionamento para o anterior é que o anterior mantinha pintada a seleção anterior ao selecionar uma célula das colunas 'A:B' ou das linhas '1:2'. Este abaixo remove a cor.
Segue arquivo.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
    Dim RngRow As Range, RngCol As Range, RngFinal As Range
    
    Range("C3:AC1800").Interior.ColorIndex = xlNone

    If Target.Column < 3 Or Target.Column > 29 Then Exit Sub
    If Target.Row < 3 Then Exit Sub
 
    Set RngRow = Range("C" & Target.Row, Target)
    Set RngCol = Range(Cells(2, Target.Column), Target)
    Set RngFinal = Union(RngRow, RngCol)
   
    RngFinal.Interior.ColorIndex = 6
   
End Sub

Osvaldo

 
Postado : 28/05/2016 9:39 pm
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Mauro, este é o problema, eu gostaria que ao clicar em qualquer célula realçasse também as datas e os horários ... mas já vi que não tem jeito, pois, ao mudar de célula o realce muda de linha e coluna, mas permanece, fica fixo, nas datas e nos horários anteriores !!! ... Mas esta última versão já está ótima!!
.
Osvaldo, valeu!! ... Esta versão já está ótima!! ... Só não entendi porque mesmo tendo a matriz no código (Range("C3:AC1800").Interior.ColorIndex = xlNone) o código continua super ativo lá depois da linha 1800!!
.

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

 
Postado : 29/05/2016 3:46 am
(@osvaldomp)
Posts: 860
Prominent Member
 

... eu gostaria que ao clicar em qualquer célula realçasse também as datas e os horários ...
Na versão abaixo somente as células onde a FC estiver ativa (estiver "On") não serão pintadas, pois a FC tem prioridade.
Fica a sugestão como lição de casa pra você: para pintar também as células com FC ativa, incremente o código para remover a FC e depois reaplicar
;)

... Só não entendi porque mesmo tendo a matriz no código (Range("C3:AC1800").Interior.ColorIndex = xlNone) o código continua super ativo lá depois da linha 1800!!
Na versão abaixo o código irá atuar até a última linha preenchida em 'A', no seu exemplo até a linha 1707.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
    Dim RngRow As Range, RngCol As Range, RngFinal As Range
    
    Range("B2:AC" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = xlNone
    Columns(1).Interior.ColorIndex = 4
    Rows(1).Interior.ColorIndex = 4

    If Target.Column < 3 Or Target.Column > 29 Then Exit Sub
    If Target.Row < 3 Or Target.Row > Cells(Rows.Count, 1).End(3).Row Then Exit Sub
 
    Set RngRow = Range("A" & Target.Row, Target)
    Set RngCol = Range(Cells(1, Target.Column), Target)
    Set RngFinal = Union(RngRow, RngCol)
   
    RngFinal.Interior.ColorIndex = 6
End Sub

Osvaldo

 
Postado : 29/05/2016 8:30 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

.
Osvaldomp, este ajuste ficou ótimo!!
.
Só tem um probleminha nesta parte do código ... pois, tá pintando a coluna A até o final da plan, e a linha também até o final - quando deveria se limitar à coluna AC e à linha 1710:
.
Range("B2:AC" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = xlNone
Columns(1).Interior.ColorIndex = 4
Rows(1).Interior.ColorIndex = 4

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

 
Postado : 29/05/2016 8:48 am
(@osvaldomp)
Posts: 860
Prominent Member
 

Verdade. Vacilo meu :oops:

substitua estas linhas

Columns(1).Interior.ColorIndex = 4
Rows(1).Interior.ColorIndex = 4

por estas

Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = 4
Range("A1:AC1").Interior.ColorIndex = 4

Osvaldo

 
Postado : 29/05/2016 9:03 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Deu erro nesta linha: Range("A1:A1810" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = 4 ... com e sem o 1810 !!!

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

 
Postado : 29/05/2016 9:16 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

.
Osvaldo, esquece, o código abaixo já funcionou!! ... Valeu!! ... Estranho, agora abri o arquivo, e está tudo como gostaria (não está mais colorindo a coluna A até o final, nem a linha 1) !!
.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim RngRow As Range, RngCol As Range, RngFinal As Range

Range("B2:AC" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = xlNone
Range("A1:A" & Cells(Rows.Count, 1).End(3).Row).Interior.ColorIndex = 4
Range("A1:AC1").Interior.ColorIndex = 4

If Target.Column < 3 Or Target.Column > 29 Then Exit Sub
If Target.Row < 3 Or Target.Row > Cells(Rows.Count, 1).End(3).Row Then Exit Sub

Set RngRow = Range("A" & Target.Row, Target)
Set RngCol = Range(Cells(1, Target.Column), Target)
Set RngFinal = Union(RngRow, RngCol)

RngFinal.Interior.ColorIndex = 6
End Sub

PS: se os moderadores tiverem acesso para alterar o título do tópico (ou acrescentar uma tag para pesquisa futura), mude para AGENDA PARA CONSULTÓRIO!!

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

 
Postado : 29/05/2016 9:32 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

.
A quem interessar, aí está a agenda final!! ...
.

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

 
Postado : 29/05/2016 12:30 pm
Página 2 / 2