Excel vba macro que busca nome e certificados de tripulante e coloca em aba resumo

Alex Sapulla · 24 de novembro de 2023

Bom dia Amigos,

Gostaria de pedir uma ajuda a quem tiver conhecimento de VBA. Estou realizando um curso de VBA, porém ainda sou iniciante e ainda não consigo criar uma macro para fazer essa planilha funcionar conforme desejado.

Basicamente, o que eu preciso, é que ao inserir o nome de um dos tripulantes do navio, apareça abaixo a relação dos certificados VENCIDOS (Expired), Próximos a Vencer (Near to Expire), Faltando (Missing) e os que estão dentro da validade ( Approved). Isto está na aba "Resume for Person"

A outra aba é uma data base com as datas de validade de todos os certificados, indicando também se estão faltando a ser entregues (indicado pela letra M - de missing) e quando não expiram, os mesmo são indicados pela frase NO EXPIRES.

Coloquei uma condicional para ficar verde (os certificados dentro da validade), amarelo (os que estão próximos a vencer - isso é, 90 dias para o vencimento), vermelho (para os que estão vencidos) e roxo com a letra M (para os que estão faltando a ser entregue - missing)

Então a macro que preciso, ela precisa buscar o nome da pessoa na data base (All crew certificate list) é jogar os nomes dos certificados (que são denominados na linha 7 da coluna I a coluna AS. Exemplo: COC (NATIONAL), AB SEAMAN / OILER / BOSUN Course, FRB Course e etc), jogar essas informações na aba "Resume for Person" para o tripulante o qual foi posto o nome lá. E precisaria colocar também o Pais (Country) e Patente (Rank) do tripulante também vinculado ao nome na hora que colocasse lá.

Quem puder me ajudar, ficaria bastante grato, pois estou quebrando a cabeça aqui com fórmulas básicas de repetição como For e condicionais IFs que não estão funcionando na minha macro.
Desde já agradeço, quem puder ajudar.

Forte Abraço pessoal !

CREW CERTICATES STATUS TESTE - ALL CERTIFICATES.xlsx

OreiaG · 24 de novembro de 2023

Olá, @Alex Sapulla

Veja se este código pode lhe ajudar.

Cole uma cópia no módulo da planilha RESUME FOR PERSON.

Será executado ao alterar o nome em E9.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, m As Long, x As Long
  If Target.Address <> "$E$9" Then Exit Sub
  Range("E10:E11,E18:E54,H18:I54,L18:M54,P18:Q54").Value = ""
  If Target.Value = "" Then Exit Sub
   With Sheets("ALL CREW CERTIFICATE LIST")
    k = .Range("G9:G" & .Cells(Rows.Count, "G").End(3).Row).Find([E9]).Row
    [E10] = .Cells(k, "F"): [E11] = .Cells(k, "H")
    For m = 9 To 45
     If .Cells(k, m) <> "NA" Then
      If .Cells(k, m) = "M" Then
       x = 5
      Else
       Select Case .Cells(k, m).DisplayFormat.Interior.ColorIndex
        Case 3: x = 8
        Case 14: x = 16
        Case 44: x = 12
       End Select
      End If
      Cells(18 + Application.CountA(Range(Cells(18, x), Cells(53, x))), x) = .Cells(7, m)
      If x <> 5 Then Cells(18 + Application.CountA(Range(Cells(18, x + 1), Cells(53, x + 1))), x + 1) = .Cells(k, m)
     End If
    Next m
   End With
End Sub

Alex Sapulla · 24 de novembro de 2023

@OreiaG

Obrigado pela ajuda.
Porém quando coloco este código, por algum motivo, a macro não roda, ela simplesmente abra a janela pra eu poder escolher uma macro, que neste caso não há nenhuma.

Você sabe dizer o porquê disso ?

OreiaG · 24 de novembro de 2023

Verifique se o código está no módulo da planilha e não no Module1.

Aproveite para alterar a linha abaixo, pois country e rank estão invertidos no código.

[E10] = .Cells(k, "H"): [E11] = .Cells(k, "F")

Se não conseguir então anexe o arquivo com o código.

Alex Sapulla · 25 de novembro de 2023

@OreiaG

Funcionou aqui,

Muito Obrigado mesmo, quebrou um galhão.

Abraço !

DJunqueira · 16 de dezembro de 2023

Legal o seu estudo, mas se quiser aprender a fazer com fórmula aí vai uma solução (Excel 365).

CREW CERTICATES STATUS com fórmula DJ.xlsx

Alex Sapulla · 4 de julho de 2024

@OreiaG @DJunqueira

Tudo bem pessoal ?

Queria tirar uma duvida, pois tive um problema com a planilha da qual utilizei a macro que voce me passou @OreiaG
A planilha funcionou perfeitamente, adicionei algumas macros (mais simples, pois sou mero mortal ainda hehe ) e ela tem funcionado normalmente.

porém quando fui atualizar, excluindo uma linha, de um tripulante que deixou de embarcar no navio, ela começou a apresentar este erro aqui abaixo:

E sinceramente, não sei como resolver.
Achei estranho, pois tenho feito esse processo de adicionar e exclui linhas inteiras (sempre quando é contrato ou demitido um tripulante) e sempre funcionou normal, mas por algum motivo, agora, quando tento analisar o resumo de um tripulante, conforme figura abaixo, acontece isso

voce saberia alguma solução para consertar esse erro ?

Desde já te agradeço,

Um Abraço !!

OreiaG · 4 de julho de 2024

1 hora atrás, Alex Sapulla disse:

voce saberia alguma solução para consertar esse erro ?

À distância eu não consigo imaginar alguma solução pois a minha Bola de Cristal está emprestada, então precisamos ver o seu arquivo Excel. Imagens não ajudam.

Anexe o seu arquivo com TODAS AS MACROS existentes nele, incluindo as que você adicionou, e descreva na própria planilha exatamente em que situações o erro ocorre.

Alex Sapulla · 4 de julho de 2024

@OreiaG

É foi mal, eu esqueci voce esqueceu sua bola de cristal, depois me passa o link dela kkkk

Então, por algum motivo que eu não sei, a planilha voltou a funcionar normalmente. Eu creio que esteja relacionado a macro que eu fiz (e que ja uso faz tempo) para informar algumas funções especificas que aparece ao lado do nome da pessoa ( Exemplo: Coxswai, Seafarer, Offshore Worker, Fire Fighter e etc). Creio que esta macro esta muito "ineficiente" pois ela varre linha por linha e demora um pouquinho pra carregar as funções ao lado.

Sem contar, que tive que adicionar um botão para fazer roda-la, ja que não consegui inseri-la pra rodar automaticamente toda vez que se troca o nome selecionado.

Vou anexar a planilha original aqui. Ela possui uma aba oculta que é para puxar de uma outra lista o nome da tripulação que esta embarcada e deixar os seus respectivos nomes marcados na aba "All Crew Certificate List"

Seria possível fazer com que essas funções especificas se atualizassem automaticamente assim que se alterasse o nome e assim eliminar esse botão (Update Specific Function).

Se puder me dar uma ajuda, ficaria bastante grato.

Abraço !

PS: Salvei com a macro desativada, caso contrario não conseguiria anexar aqui.

CREW CERTICATES STATUS - ALL CERTIFICATES.xlsx

OreiaG · 4 de julho de 2024

1 hora atrás, Alex Sapulla disse:

Então, por algum motivo que eu não sei, a planilha voltou a funcionar normalmente.

"... descreva na própria planilha exatamente em que situações o erro ocorre."

Não encontrei nas suas duas planilhas a descrição que solicitei antes, leia acima.
Embora tenha voltado a funcionar, se você não sabe porque o problema ocorria e nem porque não ocorre mais, existe o risco de ele se repetir, então eu imagino que seja do seu interesse detectar e evitar que volte a ocorrer.

_________________________________________________________________________________________________

Sem contar, que tive que adicionar um botão para fazer roda-la, ...

Informe em qual planilha está o botão e qual é o texto que está nele.
_________________________________________________________________________________________________
PS: Salvei com a macro desativada, caso contrario não conseguiria anexar aqui.

Você salvou o arquivo sem macros, pois não existe a opção de salvar com macros desativadas. Ou é com ou é sem macros.

Antes de anexar você precisa compactar o arquivo que contém macros com extensão zip, 7z,.. veja no rodapé da caixa de respostas as extensões de compactados aceitas pelo fórum.

_________________________________________________________________________________________________

Alex Sapulla · 5 de julho de 2024

@OreiaG
Coloquei na planilha o que seria necessario fazer conforme voce solicitou, Vou anexar aqui ela compactada.

Valeu, Obrigado !

New folder.zip

OreiaG · 5 de julho de 2024

"...ATUALIZASSE AUTOMATICAMENTE AS FUNCOES ( S - SEAFEARER, FF- FIREFIGHTER e etc)...

Informe:

S - SEAFEARER

1. em qual célula de qual planilha você quer que esse dado seja colocado?

2. em qual coluna de qual planilha será buscado esse dado?

FF- FIREFIGHTER

1. em qual célula de qual planilha você quer que esse dado seja colocado?

2. em qual coluna de qual planilha será buscado esse dado?

etc

1. explique o que você quer dizer com etc.

Alex Sapulla · 6 de julho de 2024

@OreiaG

Eu vou colocar uma imagem aqui explicando, acho que so olhando ela daria pra entender, mas vou explicar aqui também abaixo:

Basicamente, a mesma coisa que foi feito no "RANK" e "COUNTRY", isso é, puxar da outra aba (All crew list certificate) as informações de qual país e função a pessoa é, seria feito em relação a essas funções especificas (que são esses quadradinhos coloridos com as siglas dentro que aparece na aba "all crew list certificate" como FRC ou C, S, FF e HLO (que circulado de vermelho na imagem abaixo) e aparecem também na aba Resume for Person onde esta circulado de amarelo, na imagem abaixo.).

Quando o tripulante tem essa função a bordo, exemplo fire figher - FF, eu coloco manualmente na planilha "ALL CREW LIST CERTIFICATE", a sigla FF ao lado do nome dele. (conforme na imagem abaixo circulado de vermelho)

Quando preciso fazer um resumo daquele tripulante, eu vou para a aba RESUME FOR PERSON. Nesta aba, me dá todas as informações daquele tripulante como Certificados vencidos, Rank, Country e tambem as funções especificas dele (como no exemplo abaixo - FRC - Fast Rescue Boat Crew, S - Seafearer, FF- Firefigher).

O que eu preciso basicamente, é que puxe da aba ALL CREW LIST CERTIFICATE, essas funções especificadas (que sao inseridas manualmente nesta aba) seja puxada para aba RESUME FOR PERSON, e que ela se altere, assim que se é trocado o nome do tripulante ali.

As funções Especificas que tem são:

COXWAIS - representado pela letra C ou Fast Rescue Boat Crew representado pela sigla FRC (ambos dividem o mesmo quadrado na planilha ALL CREW LIST CERTIFICATE)
S - representado pela letra S (de seafearer) ou representado pela sigla O.W (de Offshore Worker) (ambos dividem o mesmo quadrado na planilha ALL CREW LIST CERTIFICATE)
FIRE FIGHTERS - representado pela sigla FF
H - representado pela letra H (de Helicopter Landing Officer).

Então é, mudou o nome, essas funções especificas se alteram juntamente. O mesmo que ocorre com RANK e COUNTRY.

E ai poderia assim, eliminar o botão que eu criei ( UPDATE SPECIFIC FUNCTION), que é o botao que utilizo para fazer basicamente isso que eu to pedindo. Ao invés de clicar no botão para isso, ele ja ocorreria automaticamente ao mudar o nome da pessoa. Seria basicamente isso.

VOU COLOCAR UM EXEMPLO AQUI ONDE O TRIPULANTE POSSUI QUASE TODAS AS FUNÇÕES ESPECIFICAS A BORDO (ou seja preenche todas as linhas da G8H8 ate G11H11) ELE TEM AS FUNÇÕES ESPECIFICAS DE FRC, S, FF e H (Ele não tem C - Coxswai e o O.W - Offshore Worker, porque ele já é prenchido com FRC - Fast Rescue Boat Crew e S - Seafearer)

Essas funções especificas aparecem da celulas G8:H8 ate abaixo nas celulas G11:H11 conforme mostra esse exemplo.

OreiaG · 7 de julho de 2024

@Alex Sapulla

Considerei que as respostas que solicitei no post #12 são essas abaixo.

origem dos dados >>> ALL CREW, colunas B:E

destino dos dados >>> RESUME, G8:G11

Substitua o código atual por esse abaixo que já contém as alterações de origem/destino acima.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, m As Long, x As Long
  If Target.Address <> "$E$9" Then Exit Sub
  Range("E10:E11,E18:E54,G8:G11,H18:I54,L18:M54,P18:Q54").Value = ""
  If Target.Value = "" Then Exit Sub
   With Sheets("ALL CREW CERTIFICATE LIST")
    k = .Range("G9:G" & .Cells(Rows.Count, "G").End(3).Row).Find([E9]).Row
    [E10] = .Cells(k, "F"): [E11] = .Cells(k, "H")
    [G8].Resize(4).Value = Application.Transpose(.Cells(k, "B").Resize(, 4).Value)
    For m = 9 To 45
     If .Cells(k, m) <> "NA" Then
      If .Cells(k, m) = "M" Then
       x = 5
      Else
       Select Case .Cells(k, m).DisplayFormat.Interior.ColorIndex
        Case 3: x = 8
        Case 14: x = 16
        Case 44: x = 12
       End Select
      End If
      Cells(18 + Application.CountA(Range(Cells(18, x), Cells(53, x))), x) = .Cells(7, m)
      If x <> 5 Then Cells(18 + Application.CountA(Range(Cells(18, x + 1), Cells(53, x + 1))), x + 1) = .Cells(k, m)
     End If
    Next m
   End With
End Sub

Alex Sapulla · 7 de julho de 2024

@OreiaG

Funcionou perfeitamente, muito obrigado.

Espero no futuro poder fazer essas macros mais "limpas", ja que a que eu havia criado tava bem pesada.

Valeu, abraço !!

Alex Sapulla · 8 de julho de 2024

@OreiaG
So mais uma duvida, em outra questão que estou trabalhando desta planilha, se eu quisesse colocar a foto da pessoa em questão vinculada ao nome, como no exemplo abaixo:

Haveria alguma macro que puxasse a foto desta pessoa (todas as fotos seriam salvas numa pasta só e nomeadas com nome da propria pessoa, (ex: MARCOS ANTONIO DA SILVA CRUZ.jpg))

Teria alguma macro que fizesse isso automaticamente, isso é, puxasse a foto, assim que se alterasse o nome da pessoa na lista. E caso não tivesse a foto ainda, aparecesse apenas o quadrado vazio ?

Eu vi um topico parecido, mas não consegui aplicar para o meu modelo. A ideia seria criar um quadrado (shapes) e fazer com a foto fique dentro dela ou utilizar o botao Imagem do Active Control X.

Abç !

OreiaG · 8 de julho de 2024

Experimente o código abaixo no lugar do anterior.

A foto será inserida diretamente na planilha RESUME ao selecionar o nome em E9. Se não houver foto será inserida a mensagem em F9.

obs.

1. dependendo do tamanho das fotos armazenadas na sua máquina talvez você precise alterar o tamanho da cópia inserida na planilha.

Para alterar mude na linha abaixo o valor de 100, para mais ou para menos, até acertar. Essa alteração será feita apenas uma vez, desde que todas as fotos armazenadas sejam de tamanhos iguais.

Se você não conseguir, então anexe o arquivo com uma foto colada pelo código. Não precisa ser a foto real da pessoa, mas deve ter tamanho igual ao das fotos armazenadas.

False, True, r.Left + 20, r.Top, 100, -1) >> altere o valor 100 para mais ou para menos até acertar o tamanho da foto colada na planilha

2. na linha abaixo altere o nome da Pasta que contém as fotos, se necessário

sPath = "C:\Fotos\" & [E9] & ".jpg"

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, m As Long, x As Long, shp As Shape
 Dim r As Range, sPath As String
  If Target.Address <> "$E$9" Then Exit Sub
  Range("F9,E10:E11,E18:E54,G8:G11,H18:I54,L18:M54,P18:Q54").Value = ""
  For Each shp In ActiveSheet.Shapes
   If shp.Name Like "Picture*" And shp.Top = [F7].Top Then shp.Delete
  Next shp
  If Target.Value = "" Then Exit Sub
   With Sheets("ALL CREW CERTIFICATE LIST")
    k = .Range("G9:G" & .Cells(Rows.Count, "G").End(3).Row).Find([E9]).Row
    [E10] = .Cells(k, "F"): [E11] = .Cells(k, "H")
    [G8].Resize(4).Value = Application.Transpose(.Cells(k, "B").Resize(, 4).Value)
    For m = 9 To 45
     If .Cells(k, m) <> "NA" Then
      If .Cells(k, m) = "M" Then
       x = 5
      Else
       Select Case .Cells(k, m).DisplayFormat.Interior.ColorIndex
        Case 3: x = 8
        Case 14: x = 16
        Case 44: x = 12
       End Select
      End If
      Cells(18 + Application.CountA(Range(Cells(18, x), Cells(53, x))), x) = .Cells(7, m)
      If x <> 5 Then Cells(18 + Application.CountA(Range(Cells(18, x + 1), Cells(53, x + 1))), x + 1) = .Cells(k, m)
     End If
    Next m
   End With
  Set r = [F7]
  sPath = "C:\Fotos\" & [E9] & ".jpg"
  If Len(Dir(sPath)) <> 0 Then
   Set shp = ActiveSheet.Shapes.AddPicture(sPath, _
    False, True, r.Left + 20, r.Top, 100, -1)
    shp.Height = 100
  Else: [F9] = "FOTO NÃO ENCONTRADA"
  End If
End Sub

Alex Sapulla · 9 de julho de 2024

@OreiaG

Esta funcionando direitinho. Fiz algumas pequenas alterações referente a qual celula apareceria a frase "FOTO NÃO ENCONTRADA".
Troquei para aparecer na célula F12 e alterei a frase para "PICTURE NOT FOUND". A questão toda é que se eu clico em um nome que tem foto, esta frase não desaparece e fica por detrás da foto. Como na imagem abaixo.

A macro ficou assim:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim k As Long, m As Long, x As Long, shp As Shape
 Dim r As Range, sPath As String
  If Target.Address <> "$E$9" Then Exit Sub
  Range("F9,E10:E11,E18:E54,G8:G11,H18:I54,L18:M54,P18:Q54").Value = ""
  For Each shp In ActiveSheet.Shapes
   If shp.Name Like "Picture*" And shp.Top = [F7].Top Then shp.Delete
  Next shp
  If Target.Value = "" Then Exit Sub
   With Sheets("ALL CREW CERTIFICATE LIST")
    k = .Range("G9:G" & .Cells(Rows.Count, "G").End(3).Row).Find([E9]).Row
    [E10] = .Cells(k, "F"): [E11] = .Cells(k, "H")
    [G8].Resize(4).Value = Application.Transpose(.Cells(k, "B").Resize(, 4).Value)
    For m = 9 To 45
     If .Cells(k, m) <> "NA" Then
      If .Cells(k, m) = "M" Then
       x = 5
      Else
       Select Case .Cells(k, m).DisplayFormat.Interior.ColorIndex
        Case 3: x = 8
        Case 14: x = 16
        Case 44: x = 12
       End Select
      End If
      Cells(18 + Application.CountA(Range(Cells(18, x), Cells(53, x))), x) = .Cells(7, m)
      If x <> 5 Then Cells(18 + Application.CountA(Range(Cells(18, x + 1), Cells(53, x + 1))), x + 1) = .Cells(k, m)
     End If
    Next m
   End With
  Set r = [F7]
  sPath = "Z:\A - CREW CERTIFICATION & DOCUMENTS\A - CREW CERTIFICATION\1 - CREW CERTIFICATION\CREW PICTURES\" & [E9] & ".jpg"
  If Len(Dir(sPath)) <> 0 Then
   Set shp = ActiveSheet.Shapes.AddPicture(sPath, _
    False, True, r.Left + 12, r.Top, 90, 1)
    shp.Height = 100
  Else: [F12] = "PICTURE NOT FOUND"
  End If
End Sub

Tem algo que pode ser feito para que essa frase ("PICTURE NOT FOUND") desapareça quando tiver uma foto ??

Alex Sapulla · 9 de julho de 2024

@OreiaG
Consegui resolver aqui as questoes acima, identifiquei onde teria que mudar o F12 para que fosse apagado a mensagem quando aparecesse algum nome com foto.

Muito Obrigado pela sua ajuda!