Instale o código abaixo no lugar do anterior.
Private Sub
Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim k As Long, s1 As Shape, s2 As Shape, s3 As Shape, r1 As Range, r2 As
Range, ss1 As String
If Target.Count > 1 Then Exit Sub
If Target.Value = "Autorizado(a)" Then GoTo Autoriz
If Target.Value <> "Trein. Finalizado" Then Exit Sub
Select Case Sh.Name
Case "Geral": k = 34
Case "hplc": k = 16
Case "Espectro", "Karl fischer",
"Agua", "Titulação", "Peso Medio": k = 8
Case "Validação": k = 12
Case "Teor A.": k = 6
Case "Perfil", "Perda S.": k = 10
Case Else: Exit Sub
End Select
If Application.CountIf(Cells(ActiveCell.Row, 6).Resize(, k),
"Trein. Finalizado" < k / 2 _
Or Intersect(ActiveCell, Cells(ActiveCell.Row, 6).Resize(,
k)) Is Nothing Then Exit Sub
Autoriz:
Set r1 = Cells(ActiveCell.Row - 1, 3)
For Each s1 In ActiveSheet.Shapes
If Not Intersect(s1.TopLeftCell, r1) Is Nothing Then
ss1 = s1.TextFrame.Characters.Text: Exit For
End If
Next s1
With Sheets("Treinamentos"
For Each s2 In .Shapes
If Not Intersect(s2.TopLeftCell, .Rows(7)) Is Nothing
Then
On Error GoTo jump
If UCase(Left(s2.TextFrame.Characters.Text, 4))
= UCase(Left(Sh.Name, 4)) Then
Set r2 = .Cells(13,
s2.TopLeftCell.Column).Resize(200, 4)
For Each s3 In .Shapes
If Not Intersect(s3.TopLeftCell, r2)
Is Nothing Then
If
s3.TextFrame.Characters.Text = ss1 Then
If Target.Value =
"Trein. Finalizado" Then
.Cells(s3.TopLeftCell.Row + 3, s3.TopLeftCell.Column) = Date
MsgBox "A
DATA FOI INSERIDA NA CÉLULA " & _
.Cells(s3.TopLeftCell.Row + 3, s3.TopLeftCell.Column).Address(0, 0) _
& vbLf &
"DA PLANILHA Treinamentos.": Exit Sub
Else:
.Cells(s3.TopLeftCell.Row + 5, s3.TopLeftCell.Column) = Date
MsgBox "A
DATA FOI INSERIDA NA CÉLULA " & _
.Cells(s3.TopLeftCell.Row + 5, s3.TopLeftCell.Column).Address(0, 0) _
& vbLf &
"DA PLANILHA Treinamentos.": Exit Sub
End If
End If
End If
Next s3
End If
End If
jump:
On Error GoTo 0
Next
End With
End SubPontos a serem observados nesse seu novo arquivo:
1. a referência que a macro utiliza para localizar um shape na planilha é a célula em que está
o seu canto superior esquerdo,
e por essa razão, para o correto funcionamento da macro, em todas as planilhas envolvidas,
as alturas de linhas, as larguras de colunas, as posições e as dimensões dos shapes DEVEM
ser mantidas iguais ao arquivo que anexei no post #11.
Exemplo1: na planilha Treinamentos a coluna BQ está com a largura diferente do arquivo do
post #11, em consequência as alterações feitas na planilha Perda S. correspondentes aos
funcionários da coluna BU na Treinamentos, a macro não conseguirá localizar os funcionários
na planilha Treinamentos.
Exemplo2: na planilha Treinamentos, coluna P, corrija a altura do shape Joyce.
2. como já foi alertado antes, um funcionário não pode ter múltiplos nomes, pois a macro
adotará a primeira versão encontrada do nome e em comparação com as demais
variações não as encontrará. Exemplos abaixo:
Samyle
Samile
Samily
Sthefany
Sthefane
