Basole

Veja se é isso que precisa: * Cole o código abaixo, no modulo planilha "Geral" Private Sub Worksheet_SelectionChange(ByVal Target As Range) Static rngcolor As Range Static OldColor As Variant Dim rw As Long, cl As Long Sheets("Geral").Unprotect "0" If Not rngcolor Is Nothing Then If IsArray(OldColor) Then On Error GoTo NoRestore For rw = 1 To rngcolor.Rows.Count For cl = 1 To rngcolor.Columns.Count If IsEmpty(OldColor(rw, cl)) Then rngcolor.Cells(rw, cl).Interior.ColorIndex = xlNone Else rngcolor.Cells(rw, cl).Interior.Color = OldColor(rw, cl) End If Next Next On Error GoTo 0 Else If IsEmpty(OldColor) Then rngcolor.Interior.ColorIndex = xlNone Else rngcolor.Interior.Color = OldColor End If End If End If NoRestore: On Error GoTo 0 Set rngcolor = Target ReDim OldColor(1 To Target.Rows.Count, 1 To Target.Columns.Count) For rw = 1 To Target.Rows.Count For cl = 1 To Target.Columns.Count If Target.Cells(rw, cl).Interior.ColorIndex = xlNone Then OldColor(rw, cl) = Empty Else OldColor(rw, cl) = Target.Cells(rw, cl).Interior.Color End If Next Next rngcolor.Interior.Color = -4142 Sheets("Geral").Protect "0" End Sub adaptado de: Change Cell color...

@Cfernandes eu coloquei um comando no Evento Open, para que ao abrir a planilha chama a macro que verifica e envia os e-mails. Mas eu deixei desabilitado, pois é necessario completar os dados, como os endereços de e-mails dos destinatarios. * Após ter feito isso, habilite a linha retirando a aspa simples: "Call Envia_EMail, conforme imagem acima. Para isso voce precisa usar o Agendador de Tarefas e especificar os horarios que deseja que a Planilha seja aberta para executar as ações. Como abrir programas automaticamente no Windows Para que a planilha execute as tarefas de verificar e enviar os e-mails de forma autonoma, como voce citou, coloquei um comando para salvar e fechar automaticamente. * Mas quando precisar adicionar mais dados ou para algum outro motivo, com esses comando, é necessario desabilitar todas as macros, então eu vou anexar uma outra planilha (Desabilitar_Macros), para voce abrir antes da sua planilha original (Controle de Vencimentos), com isso as macros não serão executadas e voce poderá "mexer" sem que ela feche automaticamente. Desabilitar_Macros.zip Controle de vencimentos_v1.zip

@paulocezarpicos as celulas do Excel não tem o recurso de passar o mouse sobre, e executar uma ação. Acho que é isso que está se referindo ao dizer: receber o foco. Apenas os componentes Active-x (textbox, label, combobox, frame, etc), tem este recurso. Nas celulas somente ao selecionar, o proprio nome do evento do exemplo que voce postou diz: SheetSelectionChange.

@Gabriel Gallonetti Boa noite, segue exemplo. Ajuste ao seu cenário. Sub procurarValorCopiarLinhaInteira() Dim rng As Range With Sheets("Planilha1") ' Procura o valor na planilha2, que está na planilha1 (na celula A1) Set rng = Sheets("Planilha2").Cells.Find(.Range("A1").Value, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then rng.EntireRow.Copy Destination:=.Range("A9") 'copia a linha inteira e cola na celula A9 da Planilha1 End If End With End Sub

Boa noite, segue exemplo. Ajuste ao seu cenário. Sub procurarValorCopiarLinhaInteira() Dim rng As Range With Sheets("Planilha1") ' Procura o valor na planilha2, que está na planilha1 (na celula A1) Set rng = Sheets("Planilha2").Cells.Find(.Range("A1").Value, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then rng.EntireRow.Copy Destination:=.Range("A9") 'copia a linha inteira e cola na celula A9 da Planilha1 End If End With End Sub

@ricardo_br segue sugestão em VBA. Sub BatchConvertToDocx() Application.ScreenUpdating = False Dim strFolder As String, strFile As String, wdDoc As Document strFolder = GetFolder If strFolder = "" Then Exit Sub strFile = Dir(strFolder & "\*.rtf", vbNormal) While strFile <> "" Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDoc .SaveAs2 FileName:=Left(.FullName, InStrRev(.FullName, ".")) & "docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False .Close wdDoNotSaveChanges End With strFile = Dir() Wend Set wdDoc = Nothing App Application.ScreenUpdating = True End Sub Function GetFolder() As String Dim oFolder As Object GetFolder = "" Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0) If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path Set oFolder = Nothing End Function. fonte : Converter Rtf para word

Bom dia Neste link tem um exemplo. Veja se consegue adaptar as necessidades. Pode rodar o código, no word por exemplo. Converter RTF para WORD

Segue sugestão * Em anexo exemplo Controle de vencimentos.zip

@Camila Fernandes o erro apresentado é devido valor da variavel estar fora da sub rotina. Veja as alterações no anexo: Planilha_v1.zip

@Yskhadar para cada envio de e-mail, cria um novo objeto de email CDO. Veja as alterações: Sub EnviaEmail() Application.EnableEvents = False Dim iMsg, iConf, Flds, ws Dim N As Integer Dim NEmails As Integer Set ws = Worksheets N = 2 flag = 0 NEmails = ws("Relação").Range("C1") + 1 Do While N <= NEmails Set iMsg = CreateObject("CDO.Message") Set iConf = CreateObject("CDO.Configuration") Set Flds = iConf.Fields Set ws = Worksheets schema = "http://schemas.microsoft.com/cdo/configuration/" Flds.Item(schema & "sendusing") = ws("ConfigEmail").Range("C4") 'Configura o smtp Flds.Item(schema & "smtpserver") = ws("ConfigEmail").Range("C5") 'Configura a porta de envio de email Flds.Item(schema & "smtpserverport") = ws("ConfigEmail").Range("C6") Flds.Item(schema & "smtpauthenticate") = ws("ConfigEmail").Range("C7") 'Configura o email do remetente Flds.Item(schema & "sendusername") = ws("Email").Range("C5") 'Configura a senha do email remetente Flds.Item(schema & "sendpassword") = ws("Email").Range("C6") Flds.Item(schema & "smtpusessl") = ws("ConfigEmail").Range("C8") Flds.Update ws("Relação").Cells(N, 2).Copy ws("Email").Activate ws("Email").Range("C8").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ws("Relação").Cells(N, 3).Copy ws("Email").Activate ws("Email").Range("B15").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False With iMsg 'Seu nome ou apelido .From = ws("Email").Range("C3") 'Seu e-mail .Sender = ws("Email").Range("C5") 'Email do destinatário .To = ws("Email").Range("C8") 'Cópia .CC = ws("Email").Range("C9") 'Cópia Oculta .BCC = ws("Email").Range("C10") 'Anexo .AddAttachment ws("Email").Range("B15") 'Título do email .Subject = ws("Email").Range("C12") 'Nome da sua organização '.Organization = "Escola de Pais do Brasil" 'e-mail de responder para '.ReplyTo = Worksheets("Email").Range("C3") 'Mensagem do e-mail, você pode enviar formatado em HTML .HTMLBody = ws("Email").Range("E4") & " " & Sheets("Relação").Cells(N, 1) & "<br>" & "<br>" _ & ws("Email").Range("E5") & "<br>" & "<br>" _ & ws("Email").Range("E6") & "<br>" & "<br>" _ & ws("Email").Range("E7") & "<br>" _ & ws("Email").Range("E8") & "<br>" _ & ws("Email").Range("E9") & "<br>" & "<br>" _ & ws("Email").Range("E10") & "<br>" & "<br>" _ & ws("Email").Range("E11") & "<br>" _ & ws("Email").Range("E12") & "<br>" _ & ws("Email").Range("E13") flag = 1 Set .Configuration = iConf 'Envia o email .Send End With ws("Email").Range("C8,B15").ClearContents Application.EnableEvents = True Set iMsg = Nothing Set iConf = Nothing Set Flds = Nothing N = N + 1 Loop MsgBox N - 2 & " e-mails foram enviados com sucesso", vbOKOnly, "EPB" End Sub

@Luciana Goes pode-se usar o evento AfterUpdate do textbox VBA_1.zip

@Maykon Albuquerque para o pessoal entender melhor a disposição dos dados e as formatações, o ideal é voce disponibilizar a planilha, ou modelo bem proximo do original, mas com dados ficitícios. Quanto ao problema do tamanho do arquivo, voce pode fazer upload no google drive ou oneDrive, por exemplo e colocar o link aqui.

@Yskhadar no seu codigo o anexo .AddAttachment ws("Email").Range("B15") a impressão é que a celular B15 não esta sendo atualizada, alterando o endereço do anexo. Para dar um parecer melhor seria bom se disponiblizasse a planilha, ou um modelo com alguns dados ficticios, para poder entendermos melhor o funcionamento e formatação dela.

@Camila Fernandes declaração Const não aceita variaveis, experimente declarar desta forma, contatenando a celula A2 Dim SUBPASTA_RELATORIO As String SUBPASTA_RELATORIO = "\EXTRAÇÃO\ERP\COMISSÕES\" & _ "PRESTADOR\PARTICIPAÇÃO\" & [A2] & "\"

Fiz as alteracões necessarias para encontar o respectivo registro (RG), no evento CBEditar_Click Veja se é isso que precisa: Private Sub CBEditar_Click() On Error GoTo Erro If TId = "" Or TData = "" Or Thrs = "" Or Tempresa = "" Or Tcolaborador = "" Or TRg = "" Or _ ComboCRACHA = "" Or COMBTtrabalho = "" Or COMBautorizado = "" Or TSat = "" Or CBoxTacompanhante = "" Then MsgBox "Precisa preencher todos os campos!", vbCritical, "ERRO" Exit Sub End If Dim ID As Double ID = TId Dim Data As Date Data = TData.Value Dim Linha As Long Dim rng As Range With ThisWorkbook.Worksheets("Dados") ' PROCURA PELO RG NA "COLUNA F" E RETORNA A LINHA DO REGISTRO: Set rng = .Columns("F").Find(Me.TRg.Text, LookIn:=xlValues, Lookat:=xlWhole) If Not rng Is Nothing Then Linha = rng.Row If .Cells(Linha, 1).Value = ID Then .Cells(Linha, 1).Value = ID .Cells(Linha, 2).Value = TData .Cells(Linha, 3).Value = Thrs .Cells(Linha, 4).Value = Tempresa .Cells(Linha, 5).Value = Tcolaborador .Cells(Linha, 6).Value = TRg .Cells(Linha, 7).Value = ComboCRACHA .Cells(Linha, 8).Value = COMBTtrabalho .Cells(Linha, 9).Value = COMBautorizado .Cells(Linha, 10).Value = TSat .Cells(Linha, 11).Value = Thsaida .Cells(Linha, 12).Value = CBoxTacompanhante Call Limpar MsgBox "Editado com sucesso!", vbInformation, "EDITAR" Exit Sub End If Else MsgBox "Não encontrado!", vbInformation, "EDITAR" End If End With Exit Sub Erro: MsgBox "Erro!", vbCritical, "ERRO" End Sub

@Rafael_893992 dificilmente vai achar um exemplo que atenda 100%. Quase sempre é necessário adaptar as necessidades. voce tem esses dados salvos eletronicamente falando, ou seja no Excel por exemplo? Se sim é possivel criar uma rotina em cima destes dados e formatos para atender suas necessidades. O ideal é que disponibilize um exemplo com alguns dados ficticios e formatos bem proximo do seus dados originais

Neste topico tem tem exemplo bem especifico:

@AfonsoMira colocar a lista suspensa nesta tela como o exemplo que postou, não sei como fazer, mas você pode colocar a lista suspensa para selecionar a função inserindo uma tab na faixa de opções (Ribbon) ou em um userform e um botão na tab para chamar o form.

@Rafael_893992 boa noite, já viu este tópico ?

@Luciana Goes não é necessario selecionar a aba oculta nem as celulas para fazer as alteracoes. Aproveite parte do codigo com o find que localiza dados, para fazer a alteração. Editar listbox1.zip

Nesse caso teria que colocar no meu exemplo um botão pra selecionar o nome dos principais bancos e um código vba de importação para cada respectivos layouts

Experimente essas alteracoes. Substitua o codigo que postei anteriormente por este. Dim sfd Dim Tmp As String Dim x As Long Dim m As Long Dim y As Long Dim fNum As Integer Dim ArrFd As Variant Dim xStr As String Dim T As Variant T = Array("INICIAL", "CONTINUACAO") With [L5] For Each sfd In T If VBA.Len(sfd) < 1 Then Exit Sub ArrFd = VBA.Split(sfd, ",") For xFNum = 0 To UBound(ArrFd) xStr = ArrFd(xFNum) y = VBA.Len(xStr) m = UBound(VBA.Split(.Value, xStr)) If m > 0 Then Tmp = "" For x = 0 To m - 1 Tmp = Tmp & VBA.Split(.Value, xStr)(x) .Characters(VBA.Len(Tmp) + 1, Length:=y).Font.Bold = True Next End If Next xFNum Next End With Caso persista o erro poste a planilha ou um exmeplo bem proximo do original

Ta complicado enteder o que precisa. Mas experimente: =CONT.SE(G:H;"="& G:G)

@Neodenn pode ser desta forma? With Range("L5") .Characters(WorksheetFunction.Find("INICIAL", .Value, 1), Len("INICIAL")).Font.Bold = True .Characters(WorksheetFunction.Find("CONTINUACAO", .Value, 1), Len("CONTINUACAO")).Font.Bold = True End With

Experimente desta forma: =CONT.SE(G2:H999;G2) ...e arraste.