Excel Private Sub Worksheet_Change não reconhece inclusão de um novo valor indireto

[BRUNO_H_S_L]

Amigos, 

 

Estou com problema nesse código. a principio, no momento em que uma célula receber uma informação na coluna "E" deve-se gerar uma reunião no Outlook. O código esta rodando perfeitamente desde que eu inclua manualmente essa informação. O problema é que sessa informação vem através de uma Userform e ao ser inserida o Worksheet_change não reconhece. Tenho que clicar na célula como se fosse edita-la e dar Enter. Tentei usar o Evento Calculate, que entra em conflito com o" If Target.Address = "$E$" & linha Then" e não da certo.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    
    Set olApp = New Outlook.Application             'Creating Outlook Session
    Set olApt = olApp.CreateItem(olAppointmentItem) 'Creating an Appointment
    
    linha = ActiveCell.Row - 1
    If Target.Address = "$E$" & linha Then

        If Planilha3.Cells(linha, 5) >= 1 Then
        texto = "Solicitante: " & Planilha3.Cells(linha, 1) & vbCrLf & "Origem: " & Planilha3.Cells(linha, 2) & vbCrLf & "Destino: " & Planilha3.Cells(linha, 3) & vbCrLf & "Data de inclusão: " & Planilha3.Cells(linha, 4) & vbCrLf
  
        End If
    
    With olApt
        .Subject = Planilha3.Cells(linha, 21)           'Subject
        .Start = DateAdd("D", 1, Now)                   'Enter Date + Time here.
        .Recipients.Add ("[email protected]")    'Recipient Name, Alias, or any other Attribute.
        .MeetingStatus = olMeeting                      'olAppointmentItem with Meeting status olMeeting
                                                        'becomes a OL Meeting Item.
                                                    
        .Duration = 30                                  'In Minutes
        .Body = "O referido Card está vencendo! É necessário verificar se recebeu tratativa: " & vbCrLf & vbCrLf & "Solicitante: " & Planilha3.Cells(linha, 1) & vbCrLf & "Origem: " & Planilha3.Cells(linha, 2) & vbCrLf & "Destino: " & Planilha3.Cells(linha, 3) & vbCrLf & "Data de inclusão: " & Planilha3.Cells(linha, 4) & vbCrLf                                   'Body
        .Location = "planilha"                   'Location of the meeting.
        .Display                                        'for Displaying olMeeting window.
    End With
    
    Application.Wait DateAdd("s", 2, Now)               'waiting for 2 sec to let OL window to display.
    SendKeys "%s", True                                 'Sending Mail.
    Set olApt = Nothing
    
    MsgBox "Lembrete Enviado ao Outlook com sucesso!", vbInformation

End If
End Sub

 

[André_Arruda]

Uma sugestão:

 

Porque você não insere essa mesma macro também no botão da Userform?

Ou seja, assim que clicar no botão e o dado for para  a planilha, ao mesmo tempo, a macro em questão será executada...

 

[BRUNO_H_S_L]

Não consegui,

 

Meu userform "cadastrar" esta desta forma:

 

Private Sub CommandButton_cadastrar_Click()
Range("a10000").Select
If Range("a10001").Value <> "" Then
Selection.End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
Selection.Value = TextBox_solicitante
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Origem
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Destino
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Data
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Horaenvio
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_tempolimite
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_itens
ActiveCell.Offset(0, 1).Select
ActiveWorkbook.RefreshAll
Unload UserForm_cadastro

  'Objeto de tabela dinâmica
  Dim pivotTable As pivotTable
 
  'a parte a seguir atualiza todas as tabelas dinâmicas
  For Each plan In ActiveWorkbook.Sheets
    For Each pivotTable In plan.PivotTables
        pivotTable.RefreshTable
    Next
  Next
  

End Sub

[Edson Luiz Branco]

Bem vindo, @BRUNO_H_S_L .

 

De fato, o evento Change não é disparado por alterações de valores provenientes de fórmulas ou de código. O único evento sensível a alterações desse tipo é o Calculate mesmo. Só que infelizmente este último não reconhece quais células da planilha sofreram recálculo, ou seja, não existe o parâmetro Target.

 

Pra você saber quais células foram só se guardar o valor do antes e comparar com o do depois da(s) célula(s) de interesse numa variável global a qual manterá seu valor entre chamadas ao código, aí é só comparar se o novo valor é diferente daquele salvo na variável.

 

É uma trabalheira desnecessária se você já sabe que o valor será alterado lá no Userform.

 

Portanto, o colega @André_Arruda tem toda a razão quando lhe sugeriu usar o botão do Userform e escrevi essa papagaiada toda só pra reforçar isso 

 

[BRUNO_H_S_L]

Sem problemas...

 

Agora com mais calma e depois de passar o dia todo tentando fazer isso funcionar consegui incluir no Userform com sucesso!

 

Segue o código final para ajudar futuros viajantes!

 

Private Sub CommandButton_cadastrar_Click()
Range("a10000").Select
If Range("a10001").Value <> "" Then
Selection.End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
Selection.Value = TextBox_solicitante
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Origem
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Destino
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Data
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_Horaenvio
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_tempolimite
ActiveCell.Offset(0, 1).Select
Selection.Value = TextBox_itens
ActiveCell.Offset(0, 1).Select
ActiveWorkbook.RefreshAll
Unload UserForm_cadastro

  'Objeto de tabela dinâmica
  Dim pivotTable As pivotTable
 
  'Loop por todos os objetos da planilha
  For Each plan In ActiveWorkbook.Sheets
    For Each pivotTable In plan.PivotTables
        pivotTable.RefreshTable
    Next
  Next
  
    Dim olApp As Outlook.Application
    Dim olApt As AppointmentItem
    
    Set olApp = New Outlook.Application             'Creating Outlook Session
    Set olApt = olApp.CreateItem(olAppointmentItem) 'Creating an Appointment
    
    linha = ActiveCell.Row
    
        If Planilha3.Cells(linha, 5) >= 1 Then
        texto = "Solicitante: " & Planilha3.Cells(linha, 1) & vbCrLf & "Origem: " & Planilha3.Cells(linha, 2) & vbCrLf & "Destino: " & Planilha3.Cells(linha, 3) & vbCrLf & "Data de inclusão: " & Planilha3.Cells(linha, 4) & vbCrLf
  
        End If
    
    With olApt
        .Subject = Planilha3.Cells(linha, 21)           'Subject
        .Start = DateAdd("D", 1, Now)                   'Enter Date + Time here.
        .Recipients.Add ("[email protected]")    'Recipient Name, Alias, or any other Attribute.
        .MeetingStatus = olMeeting                      'olAppointmentItem with Meeting status olMeeting
                                                        'becomes a OL Meeting Item.
                                                    
        .Duration = 30                                  'In Minutes
        .Body = "O referido Card está vencendo! É necessário verificar se recebeu tratativa: " & vbCrLf & vbCrLf & "Solicitante: " & Planilha3.Cells(linha, 1) & vbCrLf & "Origem: " & Planilha3.Cells(linha, 2) & vbCrLf & "Destino: " & Planilha3.Cells(linha, 3) & vbCrLf & "Data de inclusão: " & Planilha3.Cells(linha, 4) & vbCrLf                                   'Body
        .Location = "PLANILHA KAMBAN"                   'Location of the meeting.
        .Display                                        'for Displaying olMeeting window.
    End With
    
    Application.Wait DateAdd("s", 2, Now)               'waiting for 2 sec to let OL window to display.
    SendKeys "%s", True                                 'Sending Mail.
    Set olApt = Nothing
    
    MsgBox "Lembrete Enviado ao Outlook com sucesso!", vbInformation

 

End Sub

adicionado 1 minuto depois

Uma última dúvida, 

 

Teria como eu incluir uma data calculada em uma célula aqui no lugar do "1"? Ou melhor, data e hora?

 

.Start = DateAdd("D", 1, Now)