LaerteB

Bom dia, @Flavio De Souza Barbosa Uma dica importante, você criou um Tópico com o mesmo assunto em outro Fórum; desta forma como já existe uma reposta para a sua questão (no outro Fórum), por gentileza informe-a aqui também, para que todos que tiverem questões semelhantes possam utilizar desta solução(com isso não irá "amarrar" as pessoas que estão dispostas a te ajudar). Aguardando sua resposta e seu Feed Back ... não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, @Matheus Sena Você pode usar o que nosso amigo @osvaldomp informou, ou pode pegar este código que estou disponibilizando abaixo (os dois chegam no mesmo resultado): Private Sub CommandButton1_Click() Dim xbusca As String Dim c As Range xbusca = InputBox("Digite o valor a ser excluído.", "EXCLUIR") With Worksheets("Planilha1").Range("A:A") Set c = .Find(xbusca, LookIn:=xlValues) If Not c Is Nothing Then Worksheets(1).Activate Range(c.Address).Activate ActiveCell.Select Selection.Delete Shift:=xlUp End If End With Set c = Nothing End Sub No código acima é só colar (no VBE) dentro do "Objeto/Procedimento" acima citado, dentro do botão criado na "sheet" "Planilha1" (neste exemplo), e quando clicar no botão será aberto uma janela que tu pode escrever o valor da célula (somente da coluna "A" neste exemplo") e depois em "Ok" que será excluído somente ela e sobe o valor abaixo, sem afetar as outras colunas (como solicitou). Verifique e teste se era isso que queria... OBS: Como todos aqui, temos compromissos e não temos muito tempo para criar um arquivo do zero, pois ajudamos somente no nosso tempo livre... é muito importante você anexar uma planilha de exemplo com dados (fictícios) e que não seja o projeto inteiro ; explicando com as informações necessárias para alcançar o seu objetivo, desta forma poderemos ajudá-lo com maior rapidez e eficácia (a maioria nem olharia este Tópico sem um arquivo exemplo, pois existe muitas "variáveis" que podem impossibilitar o sucesso parcial ou total da solução proposta,se não tiver um arquivo exemplo que for disponibilizado) .. Aguardando a sua resposta e seu Feed Back... não esqueça de clicar na mãozinha... LaerteB

Boa tarde, @Aline Ramos Borges O código informado pelo amigo @osvaldomp é excelente , mas gostaria de dar minha contribuição (eu sei que este código abaixo não é "enxuto" como do "expert" @osvaldomp , mas funciona direitinho), já tinha este comigo e estava adaptando para este "Tópico", quando fui responder, já havia uma resposta (que é ótimo, sempre aprendemos com isso).. Abaixo os códigos que podem ser colocados em um módulo: Sub geraPDF() Dim guia1 As Range Dim guia2 As Range Dim linh As Long Application.ScreenUpdating = True Application.DisplayAlerts = False Application.Calculation = xlCalculationManual linh = Sheets("Planilha3").Cells(Rows.Count, 1).End(xlUp).Row Set guia1 = Sheets("Planilha1").Range("B2:AJ84") Set guia2 = Sheets("Planilha2").Range("B2:AJ84") guia1.Copy Sheets("Planilha3").Select Sheets("Planilha3").Range("A" & linh).Select ActiveSheet.Paste Application.CutCopyMode = False linh = Sheets("Planilha3").Cells(Rows.Count, 1).End(xlUp).Row + 1 guia2.Copy Sheets("Planilha3").Select Sheets("Planilha3").Range("A" & linh).Select ActiveSheet.Paste Application.CutCopyMode = False Call salvaPDF Sheets("Planilha3").UsedRange.ClearContents Set guia1 = Nothing Set guia2 = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlCalculationAutomatic End Sub Sub salvaPDF() Application.ScreenUpdating = False Sheets("Planilha3").Select pas = "W:\14. Projeto Gestão à Vista\02. Banco de Dados\06. Aging List\Nova Proposta\02. Aging List\Aging List.pdf" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=pas, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Application.ScreenUpdating = True End Sub Faça as alterações pertinentes em relação aos nomes das Sheets do seu projeto. Espero que seja também útil... OBS: Para podermos ajudá-la com maior rapidez e eficácia é necessário (na próxima abertura de um novo Tópico) tu anexar uma planilha de exemplo com dados (fictícios) e que não seja o projeto inteiro (com o trecho que está com dificuldades); explicando com as informações necessárias para alcançar o seu objetivo (se necessário incluir imagens elucidativas), pois a maioria nem olharia este Tópico sem um arquivo exemplo, por existe muitas "variáveis" que podem impossibilitar o sucesso parcial ou total da solução proposta, caso não tenha anexado o arquivo exemplo... Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, @josequali Altere o trecho do seu código que se encontra no módulo, por este que descrevo abaixo: Sub Status() Dim x As Date Dim a As Date Dim y As Integer Dim ultlin As Long Sheets("Plan1").Select ultlin = ActiveSheet.ListObjects("dados").DataBodyRange.Rows.End(xlDown).Row For y = 3 To ultlin Observe que foi incluído a linha "ultlin" e a variável dela, e foi alterado o "for" tirando o número "7" depois do "To" e incluindo o "ultlin" (foi colocado o nome da tabela do seu arquivo exemplo, mas altere para no nome da tabela que se encontra no seu projeto) . Agora funcionará como solicitou no post #23; por gentileza verificar e testar... Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, @josequali Verifiquei e realmente estava trocado alguns sinais , por esse motivo não estavam funcionando "execução, atrasado recuperável e cronograma comprometido", também alterei e retirei um pequeno trecho de uma linha... agora estão funcionando de acordo .. Abaixo o código correto, é só copiar e colar no módulo substituindo o código anterior: Sub Status() Dim x As Date Dim a As Date Dim y As Integer Sheets("Plan1").Select For y = 3 To 7 x = Cells(y, 22) a = Date If Cells(y, 21) = "" And CDate(a) = Cells(y, 22) _ Or Cells(y, 22) = "" And Cells(y, 70) = "" Then Cells(y, 73) = "Não iniciado" ElseIf Cells(y, 21) <> "" And Cells(y, 70) = "" Then Cells(y, 73) = "Em execução" End If If CDate(a) - CDate(x) <= "6" And CDate(a) > Cells(y, 22) _ And Cells(y, 21) <> "" _ And Cells(y, 70) = "" Then Cells(y, 73) = "Atrasado recuperavel" ElseIf CDate(a) - CDate(x) > "6" And CDate(a) > Cells(y, 22) _ And Cells(y, 21) <> "" _ And Cells(y, 70) = "" Then Cells(y, 73) = "Cronograma comprometido" End If If Cells(y, 70) <> "" Then Cells(y, 73) = "Concluído" End If If Cells(y, 77) <> "" Then Cells(y, 73) = "Cancelado" End If Next y End Sub Outra coisa não há necessidade de colocar esse código acima, também, no Objeto/Procedimento citado abaixo: Private Sub Worksheet_Change(ByVal Target As Range) Por gentileza exclui-lo deste OK , só deixando-o no módulo .. Agora em relação a sua menção de como executar a macro "...a macro fosse executada sem a necessidade de um botão...", já está sendo executado quando qualquer alteração nas células forem feitas, ela funcionará, veja no código que está dentro do Objeto/Procedimento - que informo abaixo veja: Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.EnableEvents = False If Target.Cells.Count > 0 Then Call Status End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub Este código acima já faz isso sem a necessidade de um botão; quando citei sobre o botão era que tu tens essa opção também se quiser Espero que agora esteja de acordo com que solicitou... verificar e teste, se tiver alguma divergência ou outra questão me informe Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, @josequali Desculpe a demora muita correria... Abaixo o código que soluciona a sua última questão, referente ao post #18: Sub Status() Dim x As Date Dim a As Date Dim y As Integer Sheets("Plan1").Select For y = 3 To 7 x = Cells(y, 22) a = Date If Cells(y, 21) = "" And CDate(a) = Cells(y, 22) _ Or Cells(y, 22) = "" And Cells(y, 70) = "" Then Cells(y, 73) = "Não iniciado" ElseIf Cells(y, 21) <> "" And CDate(a) = Cells(y, 22) _ And Cells(y, 70) = "" Then Cells(y, 73) = "Em execução" End If If CDate(x) - CDate(a) <= "6" And CDate(a) < Cells(y, 22) _ And Cells(y, 21) <> "" _ And Cells(y, 70) = "" Then Cells(y, 73) = "Atrasado recuperavel" ElseIf CDate(x) - CDate(a) > "10" And CDate(a) < Cells(y, 22) _ And Cells(y, 21) <> "" _ And Cells(y, 70) = "" Then Cells(y, 73) = "Cronograma comprometido" End If If Cells(y, 70) <> "" Then Cells(y, 73) = "Concluído" End If If Cells(y, 77) <> "" Then Cells(y, 73) = "Cancelado" End If Next y End Sub Copiar e colar em um módulo o código acima... E não esquecer de colocar o código (ou criar um botão se quiser, para executar esta macro) que mencionei no post #15, referente ao Objeto/Procedimento abaixo: Private Sub Worksheet_Change(ByVal Target As Range) Por gentileza verificar e testar no seu projeto ou no seu arquivo exemplo, se ainda não estiver como queria, informar com detalhes a sua dúvida... este código eu testei e está funcionando de acordo... Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, @sezcarv Bem vindo ao Fórum , como você é novo por aqui, não deve ter lido as regras... desta forma por gentileza ler as regras deste Fórum para ficar ciente ... Antes de qualquer coisa leia o texto abaixo: "Como todos aqui, temos compromissos e não temos muito tempo para criar um arquivo do zero, pois ajudamos somente no nosso tempo livre... é muito importante você anexar uma planilha de exemplo com dados (fictícios) e que não seja o projeto inteiro ; explicando com as informações necessárias para alcançar o seu objetivo, desta forma poderemos ajudá-lo com maior rapidez e eficácia (a maioria nem olharia este Tópico sem um arquivo exemplo, pois existe muitas "variáveis" que podem impossibilitar o sucesso parcial ou total da solução proposta,se não tiver um arquivo exemplo que for disponibilizado) .." Estou passando o código abaixo que fará o que solicitou no post #1 (sua mensagem acima), que seria criar PDF do conteúdo existente na "Planilha3", com o nome deste PDF conforme texto da célula "D2" da "Planilha1" e na pasta específica que tu mencionou acima "C:\Users\Formulários"; coloque este código em um módulo e você pode executá-lo com um botão que criares ou outra forma que achar melhor ... Sub CriarPdf() Application.ScreenUpdating = False Application.DisplayAlerts = False Worksheets("Planilha3").Activate 'ActiveSheet.ListObjects("Tabela1").Range.Select 'descomente se for Tabela _ alterando para o nome da _ Tabela que criastes ActiveSheet.Range("B2:E8").Select 'comente se for usar a linha a acima ChDir "C:\Users\Formulários" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=Sheets("Planilha1").Range("D2"), _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False Application.ScreenUpdating = True Application.DisplayAlerts = True Range("G1").Select MsgBox "Criado arquivo PDF.", vbOKOnly End Sub Por gentileza verificar, testar e ver se funciona de acordo com o seu projeto... OBS: nos próximos Tópicos que abrir, por gentileza anexar um arquivo exemplo . Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" do Botão Curtir LaerteB

Boa tarde, @josequali Eu acho que entendi o porque não estava funcionando de acordo... eu alterei pequenos trechos, primeiro tirei a ligação da Célula "Z1" que continha uma fórmula informando sempre a data atual, por um trecho de código que faz a mesma coisa... Segundo coloquei a função "CDate", desta forma agora colocará tranquilamente se for de 3 a mais anos referente a diferença entre as datas.... Terceiro o porque não estava funcionando quando era alterado algum dado nas células; é que não deviam existir as linhas que se encontram na imagem abaixo(acho que estava muito cansado e não reparei que tinha deixado estas linhas; estava testando no botão "executar sub/userform" por isso estava funcionando) ; e mais abaixo os códigos que alterei, copie e cole no arquivo exemplo e faça o teste, verificando que agora está funcionando "perfeitamente" .. Agora os códigos corretos: Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.EnableEvents = False If Target.Cells.Count > 0 Then Call Anovencido End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub Sub Anovencido() Dim lin As String Dim x As Date 'Integer Dim i, a As Date Sheets("Plan1").Select lin = 3 Do Until Cells(lin, 10) = "" x = Year(Cells(lin, 10)) a = Date i = Year(a) If CDate(i) - CDate(x) >= "3" Then Cells(lin, 11) = "Obsoleto" ElseIf CDate(x) < CDate(i) And Cells(lin, 10) < CDate(Date) Then Cells(lin, 11) = "Vencido" ElseIf CDate(x) = CDate(i) And Cells(lin, 10) < CDate(Date) Then Cells(lin, 11) = "Vencido" ElseIf CDate(x) = CDate(i) And Cells(lin, 10) >= CDate(Date) Then Cells(lin, 11) = "A Vencer" End If lin = lin + 1 Loop End Sub Agora tu não precisa mais usar as formulas, somente esta macro. Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, josequali O nosso amigo @Midori já inseriu uma forma de solucionar a sua dúvida, mas estou também colaborando com uma outra solução, verifique e veja se satisfaz o que solicitou; segue o código abaixo é copiar e colar no seu formulário: Private Sub UserForm_Initialize() '************************************************* Application.ScreenUpdating = False Application.EnableEvents = False Dim a As Integer Dim enderc As String Dim y As Long Dim ult As Long ult = Sheets("Planilha1").ListObjects("dados").Range.Rows.Count For a = 2 To ult If Planilha1.Cells(a, 11) = "Vencido" Then enderc = Planilha1.Cells(a, 11).Address y = Range(enderc).Row Rows(y).Interior.ColorIndex = 3 End If Me.Label1.Caption = "Existe Status Vencido nas linhas em vermelho!" Next Application.EnableEvents = True Application.ScreenUpdating = True '*************************************************** End Sub Teste e verifique se era o que queria.. OBS: por gentileza verificar o seu Tópico "Formula de condição SE no Word" que existe uma mensagem minha Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Pode me informar melhor o que está ocorrendo, pois modifiquei as datas das células da coluna "J" e automaticamente ele altera a Coluna "K" corretamente... o código que te passei está funcionando perfeitamente bem sem erros.. qual o problema, não estou entendendo, qual seria?? Estou colocando o arquivo exemplo em anexo que estou utilizando e está funcionando tranquilamente, verifique. Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB formula lista mestra vencimento solucao1 LB - 25-08-2020.zip

Boa noite, josequali Desculpe somente responder agora é que eu estava muito atarefado aqui ... Fiquei muito feliz que você chegou a solução via fórmula ; mas fiquei impelido de terminar uma solução via VBA com a execução de se a data de hoje for maior que 3 anos (não tinha inserido nos post anteriores). Abaixo o código que faz a mesma coisa que a sua fórmula, não precisando mais das fórmulas nas células da Coluna "K" (colar em um módulo): Sub Anovencido() Dim lin As String Dim x As Integer Dim i As Integer Sheets("Plan1").Select lin = 3 Do Until Cells(lin, 10) = "" x = Year(Cells(lin, 10)) i = Year(Cells(1, 26)) If i - x >= "3" Then Cells(lin, 11) = "Obsoleto" ElseIf Year(Cells(lin, 10)) < Year(Cells(1, 26)) And Cells(lin, 10).Value < Cells(1, 26).Value Then Cells(lin, 11) = "Vencido" ElseIf Year(Cells(lin, 10)) = Year(Cells(1, 26)) And Cells(lin, 10).Value < Cells(1, 26).Value Then Cells(lin, 11) = "Vencido" ElseIf Year(Cells(lin, 10)) = Year(Cells(1, 26)) And Cells(lin, 10).Value >= Cells(1, 26).Value Then Cells(lin, 11) = "A Vencer" End If lin = lin + 1 Loop End Sub Agora para que o código acima seja executado quando "qualquer" célula da Plan1 for alterada, é só colar este código abaixo no VBE clicando na Plan1: Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False If Target.Cells.Count > 0 Then Call Anovencido End If Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True End Sub Então esta é outra forma de fazer a mesma coisa que a sua fórmula do post #10 Aguardando o seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Para o seu caso acima, podemos fazer o seguinte, copie e cole este código abaixo em um módulo (exclua o outro código que te informei no post #5): Sub Anovencido() Dim lin As String Sheets("Plan1").Select lin = 3 Do Until Cells(lin, 10) = "" If Year(Cells(lin, 10)) < Year(Cells(1, 26)) And Cells(lin, 10).Value < Cells(1, 26).Value Then Cells(lin, 11) = "Vencido e Obsoleto" ElseIf Year(Cells(lin, 10)) = Year(Cells(1, 26)) And Cells(lin, 10).Value < Cells(1, 26).Value Then Cells(lin, 11) = "Vencido" ElseIf Year(Cells(lin, 10)) = Year(Cells(1, 26)) And Cells(lin, 10).Value >= Cells(1, 26).Value Then Cells(lin, 11) = "A Vencer" End If lin = lin + 1 Loop End Sub Agora retire todas as fórmulas das células da coluna "K", pois não vai mais precisar delas .. Espero que isto resolva, verifique Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Eu criei um código VBA para este caso em específico (pode ser feito com fórmula também), mas achei melhor assim ... Abaixo copie e cole este código em um modulo: Sub Anovencido() Dim lin As String Sheets("Plan1").Select lin = 3 Do Until Cells(lin, 10) = "" If Year(Cells(lin, 10)) < Year(Cells(1, 26)) Then Cells(lin, 11) = "Obsoleto" End If lin = lin + 1 Loop End Sub Depois no VBE Clique na Plan1 (Microsoft Excel Objetos) e cole este código abaixo: Private Sub Worksheet_Change(ByVal Target As Range) Call Anovencido End Sub Agora sempre que clicar na Sheet "Plan1" ele será executado. Espero que era o que queria Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, josequali Espero que seja isso que queria; veja a fórmula abaixo se resolve a sua dúvida: =SE(J3<HOJE();"Vencido";"A Vencer") Qualquer coisa estamos aqui para ajudá-lo Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, Brenno Colodetti Algumas humildes sugestões que me ajudaram a entregar os valores corretos, veja abaixo: Tente configurar o teu modem/roteador e os PCs para trabalharem a 1Gb/s, pode ser que os cabos que utiliza não "entreguem" o "valor" maior que 100Mb/s, ou podem estarem rompidos (desta forma pode degradar sua performance); também tem a possibilidade de algum dispositivo que esteja conectado no cabo não estar informando o correto, é que as placas da Realtek (se for o seu caso), muitas vezes, não são boas na configuração de seus drivers.. Uma forma de melhorar é tu trocar os cabos (Cat5e) por cabos "certificados" do tipo PatchCord Cat6 já montado e ser for brindado seria melhor; tente reinstalar o driver da sua placa de Rede novamente (antes desinstale esses drivers que já estão instalados). Espero que essas dicas possam resolver o seu problema, mas se não então há uma possibilidade de ser os aparelhos Modem/Roteador ou a própria placa de Rede... mas daí é melhor ver algum especialista na área, ou esperar alguém daqui que tenha maior conhecimento do assunto que possa dar uma luz.. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, josequali Amigo, agora consegui resolver este seu "problema"; testei em minha máquina virtual e com algumas alterações foi enviado com sucesso .. Agora vamos as informações e o código com suas alterações; primeiro eu testei com meu Browser principal (no meu caso é o Firefox, e não tem problema se o seu é o Chrome da no mesmo), não precisa estar aberto o Browser; 2º Quando clicar no botão "Whatsapp" do seu "form" ele abrirá o seu Browser e logo em seguida a URL do "web.whatsapp", mas tu terás que inserir o código QR dele (antes disso saia de todos os "web.whatsapp" primeiro, clicando no celular "web.whatsapp" e depois em sair de todos); Quando abrir o WhatsApp no Browser, o programa irá executar todo o seu processo e enviar a mensagem para o contato .. Abaixo o trecho do código com suas alterações que estão funcionando: Private Sub btnenviar_Click() ' Shell "C:\Program Files\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/" ActiveWorkbook.FollowHyperlink Address:=" https://web.whatsapp.com/" Application.Wait (Now + TimeValue("00:00:08")) Do Until Sheets("bancodedados").Cells(linha, 7) = "" Application.Wait (Now + TimeValue("00:00:04")) texto = Cells(linha, 8) contato = Cells(linha, 7) Application.Wait (Now + TimeValue("00:00:04")) Call SendKeys("{TAB}", True) Application.Wait (Now + TimeValue("00:00:01")) 'acrescentado esta linha Call SendKeys(contato, True) Application.Wait (Now + TimeValue("00:00:01")) 'acrescentado esta linha Call SendKeys("~", True) 'entra na tela do contato no WhatsApp Application.Wait (Now + TimeValue("00:00:04")) Call SendKeys(texto, True) Application.Wait (Now + TimeValue("00:00:01")) 'acrescentado esta linha Call SendKeys("~", True) linha = linha + 1 Loop Estou também anexando o arquivo exemplo com todas as alterações para que tu faça o teste e verifique se era isso teria que fazer . Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB whatsapp envio de mensagem solucao 2 LB - 23-08-20.zip

Boa tarde, josequali Copie e cole este código abaixo no seu arquivo exemplo: Private Sub UserForm_Initialize() Sheets("Plan1").Select Range("A1").Select Selection.Formula = "=Login_win()" Call SendKeys("~", True) End Sub Verifique se era o que queria .. OBS: não esqueça de sempre colocar os códigos dentro do "<>" que se encontra no menu acima da sua resposta, como no exemplo da imagem que anexei. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Altere como informo abaixo: No: Private Sub btnenviar_Click() Altere os dois comandos que aparecem, como: Call SendKeys("{ENTER}", True) Para: Call SendKeys("~", True) Por gentileza deixe como coluna "8" no "texto", não altere como mencionou na mensagem acima... Outra coisa se quiser aumentar para mais alguns segundos (tipo de 04 para 06 ou 08), se achar que é pouco tempo: Application.Wait (Now + TimeValue("00:00:04")) Por gentileza verificar e ver se agora funciona de acordo.. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Então, se eu entendi o que solicitou, seria acrescentar o código mais abaixo no objeto e procedimento: Private Sub btnalterar_Click() Acrescentando esse código: '********************** Dim OptIncidente, OptIncidente2 As Object For Each OptIncidente In Frame4.Controls If OptIncidente.Value = True Then Range("J" & linha).Value = OptIncidente.Caption End If Next OptIncidente For Each OptIncidente2 In Frame5.Controls If OptIncidente2.Value = True Then Range("K" & linha).Value = OptIncidente2.Caption End If Next OptIncidente2 Call filtrar '********************** Aproveitei os códigos anteriores e alterei para os optionbuttons serem incluídos no botão alterar como queria; além disso inseri o "filtrar" para atualizar o ListBox1 OBS: quando colocar os códigos na sua mensagem, insira-os dentro "<>" que se encontra na barra de ferramentas acima Verifique se era o que solicitou .. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Bom dia, josequali Valeu @Midori , eu já estava para escrever o código quando vi que tu tinha solucionado (bem também só tinha visto agora a pouco o seu caso josequali)... LaerteB

Boa tarde, josequali Agora com a explicação mais acima entendi o que queria ... Vou dar uma ajudinha no seu caso, pois o amigo @Midori já colocou com maestria o código que fará o que quer.. mas estou colocando já com as alterações para o seu projeto, conforme abaixo (é só copiar e colar no "Private Sub Txtid_Change()"): Dim OptIncidente, OptIncidente2 As Object For Each OptIncidente In Frame4.Controls If OptIncidente.Caption = ListBox1.List(ListBox1.ListIndex, 9) Then OptIncidente.Value = True End If Next OptIncidente For Each OptIncidente2 In Frame5.Controls If OptIncidente2.Caption = ListBox1.List(ListBox1.ListIndex, 10) Then OptIncidente2.Value = True End If Next OptIncidente2 Por gentileza corrigir os nomes de cada optionbutton com o correto que se encontra na planilha, para não dar o erro de não ser encontrado... exemplo no optionbutton8 está como "Moderado" e na Planilha como "Médio"... Espero que seja isto que queria .. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Não sei se entendi o que quer, mas estou deduzindo que tu queres que no ListBox1 apareça também as colunas 10 e 11; desta forma dentro do procedimento: Sub filtrar() Copie esta linha e cole no lugar da anterior, como se segue abaixo: Me.ListBox1.ColumnWidths = "30; 130; 50; 2; 2; 2; 2; 2; 2; 95; 95; 2; 2; 2; 2" Com isso vai aparecer no ListBox1 estas duas colunas (10 e 11) Verifique se era isso que queria .. Qualquer dúvida poste novamente Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, josequali Então verifiquei e percebi que não tinha colocado uma linha em um trecho de código, sem essa linha ele não colocava na coluna "G2" da Sheets "bancodedados" a mensagem do Tipo... Abaixo está a correção, é só você substituir o que tinha antes por esse: Private Sub ComboBox1_Change() Sheets("bancodedados").Select If ComboBox1.Text = "Tipo1" Then Range("H2").Value = "Uma nova solicitação de ervilha do Tipo1 foi solicitada, verificar o sistema." ElseIf ComboBox1.Text = "Tipo2" Then Range("H2").Value = "Uma nova solicitação de ervilha do Tipo2 foi solicitada, verificar o sistema." ElseIf ComboBox1.Text = "Tipo3" Then Range("H2").Value = "Uma nova solicitação de ervilha do Tipo3 foi solicitada, verificar o sistema." End If End Sub Verifique se isto ajuda na solução do seu problema... Se ainda houver qualquer problema informe aqui novamente, espero que desta vez não precise . Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa tarde, LucasExcel O nosso amigo Midori já informou isso no post #2, observe que o: Private Sub CommandButton1_Click() é o botão "Cadastro" do seu arquivo exemplo. Quando clicar o botão "Cadastro" será executado os comandos que solicitou. Aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB

Boa noite, josequali Para você ter um "contador numérico" sem se preocupar em excluir linhas e perder esses "ID" já registrados, tem que utilizar esses códigos abaixo. Para o Botão "Novo": Private Sub btncadastro_Click() Incluir um trecho de código, conforme abaixo: Dim cont As Long cont = Sheets("bancodedadosocorrencia").Range("AB2").Value + 1 Sheets("bancodedadosocorrencia").Range("AB2").Value = cont Me.Txtid.Value = Range("AB2").Value 'OBS: para adicionar ao ID um valor toda vez que fizer um novo registro (o valor esta na celula b1) Observe que foi alterado o Range de "B1" para "AB2", você pode deixar como Range no "B1", mas terá que excluir a fórmula dentro desta célula. E para o Botão "Salvar": Private Sub btnOK_Click() Incluir este trecho de código abaixo: Txtid.Value = Range("AB2").Value Alterando neste caso também somente a Range de "B1" por "AB2", se quiser deixar o "B1" faça o que lhe informei nas linhas acima.. Agora mesmo que excluir tudo dentro da Tabela a contagem sempre seguirá a última linha salva - exemplo se for 15 a próxima será 16, mesmo que todos os dados das linhas forem excluídos, como tinha solicitado. Porém para continuar a partir da última linha já registrada no seu projeto, coloque manualmente na célula "AB2" ou se for continuar com a célula "B1" (lembre de excluir neste caso a fórmula desta célula) o último "ID" já cadastrado, como no arquivo exemplo coloque o número "15".. Espero que seja isso que estava querendo.. Estou aguardando sua resposta e seu Feed Back ... se foi útil, não esqueça de clicar na "mãozinha" LaerteB