Oi Charlie,
Segue novo arquivo com o novo código.
Também deixo o novo código aberto aqui no tópico, para efeitos didáticos.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo TratarErro
Dim shtRelacao As Worksheet
Dim shtEspelho As Worksheet
Dim rng As Range
Set shtRelacao = Target.Parent
For Each rng In Target.Cells
If rng.Column = 8 Then
If rng.Value = "ativo" Then
Call CriarPlanilha(shtEspelho, shtRelacao, rng)
ElseIf rng.Value = "desligado" Then
Call RemoverPlanilha(shtRelacao, rng)
End If
End If
Next rng
Set shtEspelho = Nothing
Set shtRelacao = Nothing
Set rng = Nothing
Exit Sub
TratarErro:
MsgBox "Deu erro." & vbCrLf & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Erro, evento Worksheet_Change"
End Sub
Public Function fnPlanilhaJaExiste(strNome As String) As Boolean
On Error Resume Next
Dim sht As Worksheet
For Each sht In ThisWorkbook.Worksheets
If sht.Name = strNome Then
fnPlanilhaJaExiste = True
Exit Function
End If
Next sht
End Function
Public Sub CriarPlanilha(ByRef shtEspelho As Worksheet, ByRef shtRelacao As Worksheet, ByRef rng As Range)
On Error GoTo TratarErro
If Not fnPlanilhaJaExiste("EP-" & shtRelacao.Range("A" & rng.Row).Value) Then
If MsgBox("Este funcionário não tem planilha de ponto." & vbCrLf & "Deseja criar uma agora?", vbYesNo + vbQuestion) = vbYes Then
With ThisWorkbook
.Worksheets("espelho de ponto individual").Copy After:=.Worksheets(.Worksheets.Count)
Set shtEspelho = .Worksheets(.Worksheets.Count)
End With
With shtEspelho
.Name = VBA.Left("EP-" & shtRelacao.Range("A" & rng.Row).Value, 31)
.Range("B4").Value = shtRelacao.Range("A" & rng.Row).Value
End With
End If
End If
Exit Sub
TratarErro:
MsgBox "Deu erro." & vbCrLf & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Erro, rotina CriarPlanilha"
End Sub
Public Sub RemoverPlanilha(ByRef shtRelacao As Worksheet, ByRef rng As Range)
On Error GoTo TratarErro
If fnPlanilhaJaExiste("EP-" & shtRelacao.Range("A" & rng.Row).Value) Then
If MsgBox("Este funcionário tem planilha de ponto." & vbCrLf & "Deseja removê-la agora?", vbYesNo + vbQuestion) = vbYes Then
With Application
.DisplayAlerts = False
ThisWorkbook.Worksheets("EP-" & shtRelacao.Range("A" & rng.Row).Value).Delete
.DisplayAlerts = True
End With
End If
End If
Exit Sub
TratarErro:
Application.DisplayAlerts = True
MsgBox "Deu erro." & vbCrLf & Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Erro, rotina RemoverPlanilha"
End Sub
Qquer coisa, grita,
F.F.
Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel
Postado : 25/06/2012 11:41 am