Notifications
Clear all

Exlcuir planilha ao determinar um determinado status

6 Posts
2 Usuários
0 Reactions
1,781 Visualizações
Charlie-81
(@charlie-81)
Posts: 290
Reputable Member
Topic starter
 

Ilustres...

Boa tarde!

Há alguns dias o fernando.fernandes me ajudou em uma planilha onde, quando defino o status de um funcionário como "Ativo" é gerada automaticamente uma planilha de espelho de ponto. Agora, queria o inverso, quando definir este status como "Desligado", a sua planilha individual de ponto seja excluida também.

Blue eye | MB Intel Extreme DX58SO | Termaltake 775W | I7 950 LGA 1366 (Overclock 5.3 GZ) | Corsair Vengeance 16 GB | WC Corsair H70 | Aerocool Touch 2000 | Razer Mamba 4G | Som Volcano 50W RMS | Cooler Zalmam | HD 2TB | Radeon HD 8670 | Monitor 32'

 
Postado : 25/06/2012 9:55 am
Charlie-81
(@charlie-81)
Posts: 290
Reputable Member
Topic starter
 

Segue o anexo onde era feita a inclusão quando o status era definido como "Ativo", agora, para que seja adicionado o código para excluir quando for definido como "Desligado".

Blue eye | MB Intel Extreme DX58SO | Termaltake 775W | I7 950 LGA 1366 (Overclock 5.3 GZ) | Corsair Vengeance 16 GB | WC Corsair H70 | Aerocool Touch 2000 | Razer Mamba 4G | Som Volcano 50W RMS | Cooler Zalmam | HD 2TB | Radeon HD 8670 | Monitor 32'

 
Postado : 25/06/2012 10:02 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Charlie, estou no trabalho agora, e eles não tem WinRAR ou qquer compactador/descompactador que leia esta extensão. Vc pode por favor reenviar, mas em formato zip?
Valeu!

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

 
Postado : 25/06/2012 11:05 am
Charlie-81
(@charlie-81)
Posts: 290
Reputable Member
Topic starter
 

Fernando...

Segue o arquivo em formato zip.

Blue eye | MB Intel Extreme DX58SO | Termaltake 775W | I7 950 LGA 1366 (Overclock 5.3 GZ) | Corsair Vengeance 16 GB | WC Corsair H70 | Aerocool Touch 2000 | Razer Mamba 4G | Som Volcano 50W RMS | Cooler Zalmam | HD 2TB | Radeon HD 8670 | Monitor 32'

 
Postado : 25/06/2012 11:27 am
Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

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
Charlie-81
(@charlie-81)
Posts: 290
Reputable Member
Topic starter
 

Perfeito fernando.fernandes

Blue eye | MB Intel Extreme DX58SO | Termaltake 775W | I7 950 LGA 1366 (Overclock 5.3 GZ) | Corsair Vengeance 16 GB | WC Corsair H70 | Aerocool Touch 2000 | Razer Mamba 4G | Som Volcano 50W RMS | Cooler Zalmam | HD 2TB | Radeon HD 8670 | Monitor 32'

 
Postado : 25/06/2012 12:52 pm