Muca Costa

você tem que excluir esse passo Selection.ClearContents na Macro1

Aqui tem um passo a passo para criar formulários: https://www.youtube.com/watch?v=kmD9wMyvxY4

Sub ExecutaMacros() Call Macro1 Call Macro2 Call Macro3 End Sub Sub Macro1() Sheets("Planilha1").Select Range("B1").Select Range("B1") = "Executou Macro 1" End Sub Sub Macro2() Sheets("Planilha2").Select Range("B1").Select Range("B1") = "Executou Macro 2" End Sub Sub Macro3() Sheets("Planilha3").Select Range("B1").Select Range("B1") = "Executou Macro 3" End Sub

É só descompactar com WinRAR. A planilha proposta tem macro (xlsm)

Seu código com algumas mudanças: Aqui funcionou... Sub Grava() Dim Guia As String 'Texto obrigatorio If Range("B2").Value = "" Then MsgBox "Nome é Obrigatório" Else 'Renomeia e salva nova aba Sheets("NOVO").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = Sheets("NOVO").[B2] Guia = ActiveSheet.Name With Sheets("NOVO").[B2] = [B2] 'Cola pasta clientes Range("B2").Select Selection.Copy Sheets("CLIENTES").Select Range("B3").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("NOVO").Select Range("B4").Select Application.CutCopyMode = False Selection.Copy Sheets("CLIENTES").Select Range("C3").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("F3").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=ROW()" Range("A3").Select ActiveCell.FormulaR1C1 = "=R[1]C+1" Rows("3:3").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'Limpa tudo Sheets("NOVO").Select Range("B2").Select Selection.ClearContents Range("B4").Select Selection.ClearContents Sheets("NOVO").Select Range("B2").Select Selection.ClearContents Range("B4").Select Selection.ClearContents Range("A8:D48").Select Selection.ClearContents Range("F8:G48").Select Selection.ClearContents Range("G8").Select Sheets("CLIENTES").Select Range("D4").Select ActiveCell.FormulaR1C1 = "VER" Range("D4").Select ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ Guia & "!A1", TextToDisplay:="VER" Sheets("NOVO").Select End With End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Guia As String Guia = ActiveSheet.Name If Target.Column <> 3 Then Exit Sub If Target.Offset(, 0).Value >= 1 Then Atualiza End If Sheets(Guia).Select End Sub Tente assim...

EM UM MÓDULO: Sub Atualiza() Sheets("TEMAS").Select Range("B1").Select Columns("B:B").Select Selection.Copy Columns("C:C").Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False End Sub NA GUIA "2021": Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 3 Then Exit Sub If Target.Offset(, 0).Value >= 1 Then Atualiza End If End Sub

Sub Duplica() Dim P As String With ActiveSheet P = .Cells(.Rows.Count, "A").End(xlUp).Row End With Range("A" & P).Select Selection.Copy Range("A" & P + 1).Select ActiveSheet.Paste Range("A" & P + 2).Select ActiveSheet.Paste Application.CutCopyMode = False End Sub

3° Como eu coloco os dizeres no começo do corpo do email? Os dizeres Prezados" -> pula duas linhas -> xxxxxxxx Podem ser incluídos junto com a tabela em F1 e F2 por exemplo De: ActiveSheet.Range("F3:I31").Select Para: ActiveSheet.Range("F1:I31").Select

Corrigindo: DE: Email.HTMLBody = sh.Range("F3:I31") & "<img border='0' src='temp.gif' width='1267' height='460'>" PARA: Email.HTMLBody = "<img border='0' src='Carregamento.gif' width='1267' height='460'>"

Sub MacroEmail() Dim sh As Worksheet grafico_para_imagem On Error Resume Next Set sh = Sheets("Tabela dinamica - Volume") Set objeto_outlook = CreateObject("Outlook.Application") Set Email = objeto_outlook.CreateItem(0) Email.Display Email.CC = "" 'Informe Email.To = "" 'Informe Email.Subject = "Relatório de expedição rodoviário" ActiveSheet.Range("F3:I31").Select Selection.Copy Email.Attachments.Add ThisWorkbook.Path & "\Carregamento.gif", olByReference, 1 Email.HTMLBody = sh.Range("F3:I31") & "<img border='0' src='temp.gif' width='1267' height='460'>" Email.Display Application.SendKeys "{TAB 4}" Application.SendKeys "^v" End Sub Sub grafico_para_imagem() Set Gráfico = Sheets("Tabela dinamica - Volume").ChartObjects(1).Chart ArquivoGIF = ThisWorkbook.Path & "\Carregamento.gif" Gráfico.Export Filename:=ArquivoGIF, FilterName:="GIF" End Sub

Para podermos lhe ajudar, seria melhor você anexar sua planilha.

Outra sugestão. Listar células filtradas.rar

Caro Dinei San, desculpe, a minha intenção é lhe ajudar. Porém a planilha que proponho tem macro e está na extensão xlsm. A solução proposta é em Excel, é só você extraí-lo. Norma do Fórum: Tipo de arquivos permitidos log, txt, ini, zip, zipx, rar, 7z, jpg, png, gif, doc, docx, xls, xlsx, pdf, ppt, pps, pptx, bmp, csv, tiff, xml, jpeg Tamanho total do arquivo 4,88MB

https://www.win-rar.com/open-rar-file.html?&L=9