Este fórum está sendo desativado

[Narcisosousa]

Oi pessoal, como vocês estão? espero que bem

Estou precisando de ajuda com uma planilha pra controlar entrada de senhas, elas vão ajudar minha equipe a controlar a chegada e entrada de caminhões, o objetivo é colorir a celula com a senha de acordo com a chegada ou saída do caminhão, estou fazendo isso com macro, mas para 400 registros vou ter que criar 800 macros, existe uma maneira mais prática de fazer isso? não precisa seguir a mesma estrutura da planilha em anexo não, só preciso que a senha mude de cor com alguma estrutura de controle ou algo parecido.

[osvaldomp]

Veja se esta solução ajuda.

Funciona igual ao processo atual, ao clicar na imagem da coluna B pinta D de amarelo e ao clicar na imagem de C pinta de verde.
No lugar de 800 códigos você irá precisar de apenas um, este abaixo.
Se você quiser, a inserção da senha em D poderá sr incluída no código, na parte que pinta de amarelo ou na que pinta de verde, para isso precisamos saber o critério para determinar qual o número que será inserido.

Código: Selecionar todos

Sub PintaCélula()
  If ActiveSheet.Shapes(Application.Caller).TopLeftCell.Column = 3 Then
   Cells(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row, 5).Interior.Color = vbYellow
  Else: Cells(ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row, 5).Interior.Color = vbGreen
  End If
End Sub

#
Como preparação você precisa vincular TODAS as imagens das colunas B e C a esse código.

Ainda, na planilha que você disponibilizou há imagens sobrepostas (a partir de D8 e até o final) que devem ser removidas.
Outra correção necessária é que as imagens da coluna C estão "invadindo" a célula de cima o que acarretará resultados indesejados do código acima.

Como bônus, se você preferir, o código abaixo irá corrigir os dois problemas citados acima e também irá vincular todas as imagens ao primeiro código. Rode-o apenas uma vez e rode-o novamente se você incluir imagens nas colunas B e C.

Código: Selecionar todos

Sub ArrumaEAtribuiMacroImagens()
 Dim sh As Shape, t As Double, x As Double, lin As Long
  'remove imagens sobrepostas na coluna C
  For Each sh In ActiveSheet.Shapes
   If sh.TopLeftCell.Column = 4 Then
    t = sh.Top
    If t = x Then
     sh.Delete
    End If
    x = t
   End If
  Next sh
  'desloca para baixo as imagens que estiverem invadindo a célula de cima
   lin = 4
  For Each sh In ActiveSheet.Shapes
   If sh.TopLeftCell.Column = 4 Then
    If sh.TopLeftCell.Row < lin Then
     sh.IncrementTop 1.2
    End If
    lin = lin + 1
   End If
  Next sh
 'vincula todas as imagens das colunas B e C à macro PintaCélula
  For Each sh In ActiveSheet.Shapes
   sh.OnAction = "PintaCélula"
  Next sh
End Sub

[Narcisosousa]

Era exatamente isso que eu estava precisando, me ajudou muito, muito obrigado mesmo, de verdade