Basole

Ricardo, seja bem vindo a bordo! Normalmente eu utilizo a Application,StatusBar (display na parte de baixo a esquerda), para informar o usuario sobre o progresso da macro. Mas vamos a seu caso. Minha sugestão é eliminar a 'Second_Macro()' e no lugar dela a sua macro: 'Filtros_Automáticos()'. voce executa a macro 'DisplayTextMsgBox()' esta macro ativa a caixa de texto (texbox), chama a macro 'Filtros_Au...' depois retorna e deleta a msg (cx. de texto). Então o codigo fica assim: Sub DisplayTextMsgBox() ' Select the first worksheet. Worksheets(1).Select ' Create a text box on the active worksheet. ActiveSheet.TextBoxes.Add(215, 195, 91.5, 60).Select ' Store the name of Worksheet in variable StoreWSNM. StoreWSNM = ActiveSheet.Name ' Store the name of Text Box in variable StoreNM StoreNM = Selection.Name ' Set the Font and Border properties of the text box. With Selection With Selection.Characters.Font .Name = "Arial" .FontStyle = "Bold" .Size = 20 End With With Selection.Border .LineStyle = xlContinuous .ColorIndex = 1 .Weight = xlThick End With 'Set round corners for the text box. .RoundedCorners = True 'Set message text color to black. .Interior.ColorIndex = 15 'Assign message text to the text box. .Characters.Text = "Please Wait..." End With ' Actual macro that will run while Please Wait... ' message is being displayed. 'Second_Macro ' desabilitada a "Second Macro" Call Filtros_Automáticos ' AQUI: Chama a sua macro ' Makes sure the proper Worksheet is selected. Worksheets(StoreWSNM).Select ' Makes sure the proper text box is selected. ActiveSheet.TextBoxes(StoreNM).Select ' Deletes the Please Wait... text box. Selection.Delete End Sub 'abx.

Bom dia guilherme, no codigo vba, nas configuraçoes de zoom, voce pode aumentar o valor pra mais 1 ou mais 2, ou seja se estiver 62 altere para 63 ou 64, dependendo do resultado obtido. E tambem em layout da pagina -> margens, voce pode ajustar para o minino do lado esquerdo e direito. abx.

Boa tarde Mimoso, eu nao entendi o que que é ( Tabela4[#TUDO] ) , é o nome da tabela? O excel nao aceita usar caracters especiais para esta finalidade. Eu sempre carreguei o listbox com os dados de tabela assim: Me.ListBox1.RowSource = "Tabela1" ou Me.ListBox1.RowSource = "plan1!Tabela1" ..e nunca tive problemas .. abx.

Guilherme, voce tem que ajustar as colunas até que todas as colunas com conteudo fiquem 'dentro' da linha pontilhada * * (esta linha é criada quando o excel cria uma area de impresão) De qq forma, estou enviando novamente o arq. pois nao tenho certeza se savei c/ essas alteraçoes no momento que fiz o upload. abx. Report 2015 - Foton ESN 36513214 - Copy.zip

Existe outras maneiras de se fazer isso, mas segue sugestão em vba: Sub Copiar_ContratoTabelas() Dim d As Database Dim rs_tb1 As Recordset Dim rs_tb2 As Recordset Dim rs_tb3 As Recordset Dim Cnt1 As Field, Cnt2 As Field, cnt3 As Field Dim ct As String: ct = 0 Set d = CurrentDb() Set rs_tb1 = d.OpenRecordset("tabela1") Set rs_tb2 = d.OpenRecordset("tabela2") Set rs_tb3 = d.OpenRecordset("tabela3") Set Cnt1 = rs_tb1.Fields("Contrato") Set Cnt2 = rs_tb2.Fields("Contrato") Set cnt3 = rs_tb3.Fields("Contrato") rs_tb1.MoveFirst While Not rs_tb1.EOF rs_tb2.AddNew rs_tb3.AddNew Cnt2 = Cnt1 cnt3 = Cnt1 On Error GoTo Sai rs_tb2.Update rs_tb3.Update ct = ct + 1 rs_tb1.MoveNext Wend rs_tb1.Close rs_tb2.Close rs_tb3.CloseSai: If ct < 1 Then MsgBox "Nenhum registro foi copiado." & Chr(10) & "O campo [ Contrato ] nao aceita registros duplicados !", 64, "Aviso" Exit Sub End If If ct > 0 Then MsgBox ct & " Dados copiados c/ sucesso", 0, "Sucesso"End Sub funcao p/ chamar a macro: Function ImportarContrato()Call Copiar_ContratoTabelasEnd Function abx. Database-Exem.zip

Se o 'pobrema' é funcao ? faça novamente o procedimento e referencie esta função: Function RodaMacro()Call Calcular_MesesMsgBox "Seja Bem Vindo! ", 0, "Olá "End Function cole o cod (funcao) acima no mesmo modulo: módulo1. ' * nao precisa criar outro modulo'

Bom dia guilherme, existem diferenças de dimensões da largura de pag. entre as abas, apesar da 1ª aba "Report" se estender até a coluna "L" a 2ª a "H" e a 3ª a "G" as medidas das larguras são diferentes entre elas, por isso que configurei a 1ª aba c/ 'zoom 65' e as demais c/ 'zoom 49'. Veja o que acontece (vide print 1) se padronizar o zoom para as 3 abas c/ a larg. das colunas como estão: (a ultima coluna, acaba 'caindo' para outra pagina) Agora com estreitamento de ajuste das colunas das abas 2 e 3 c/ o zoom 65 p/ abas "report, Failures,Correct" (vide print 2): Bom concluindo: para que as 3 paginas PDF ficam (com a largura ) padronizadas, é necessario padronizar as larguras das 3 abas. Segue o link da planilha c/ estreitamento da larg. das colunas p/ chegar ao ajuste acima. Veja se consegue configurar as formatações como fonte tamanho da fonte etc. https://drive.google.com/file/d/0Bz6qa6N0K3fKeDR5d3YzUE5YYUE/view?usp=sharing

segura a mao ai que eu fazendo as alteracoes q pedui..... abx.

O que está querendo é que a aba "report" e as outras 2 caíbam em 1 pagina (cada uma) , e com orientação retrato ? Bom Isto é uma questão de ajuste de conteúdo (dados) ao tamanho da pagina. Eu deixei no codigo essas opções de ajustes p/ voce poder configurar: No código na 1ª page setup da aba "report" altere conf. abaixo: De: .Zoom = False Para: .Zoom = 65De: .Orientation = xlLandscape Para: .Orientation = xlPortrait E + abaixo na page setup das outras duas abas De: .Zoom = False Para: .Zoom = 49De: .Orientation = xlLandscape Para: .Orientation = xlPortrait veja o resultado (anexo), c/ os ajustes acima abx. TestePDF-201532.pdf

Vja aqui tem um passo a passo p/ criar um autoexec p/ executar a macro ao abrir o bd: http://mikeperris.com/access/autoexec-macro-running-at-access-startup.html abx.

Olá Guilherme, veja agora se é quase ou isso. Fiz as altrações no código, a macro cria os intervalos de dados (range.name) nas 3 abas, seleciona-as e exporta 1 unico PeDeéFe Inclui tbem. a macro 'Inserir_imagens' e insirei umas imagens para teste, pois a plan que voce compartilhou, veio sem. abx. Report 2015 - Foton ESN 36513214 - Copy.zip

Guilherme, mudei o codigo para o modulo 1 e agora as duas sheets usam o mesmo codigo. abx. Report 2015 - ESN.zip

Segue exemplo, altere de acordo c/ o nome das suas plan(s) Sub Teste3AbasPDF() Dim NomArq As String Dim stArqName As String With ThisWorkbook.ActiveSheet.PageSetup Worksheets("plan1").PageSetup.PrintArea = Worksheets("plan1").UsedRange.Address Worksheets("plan2").PageSetup.PrintArea = Worksheets("plan2").UsedRange.Address Worksheets("plan3").PageSetup.PrintArea = Worksheets("plan3").UsedRange.Address .Zoom = False '(Pode-se ajustar o conteudo ao tam. da pag. Ex 65, 70,79,85, 95 a 100) .Orientation = xlPortrait ' xlLandscape (para paisagem) End With NomArq = "TestePDF-" & Year(Date) & Month(Date) & Day(Date) stArqName = ActiveWorkbook.Path & "\" & NomArq & ".pdf" ThisWorkbook.Sheets(Array("Plan1", "Plan2", "Plan3")).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ stArqName _ , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ :=False, OpenAfterPublish:=True 'False (para nao abrir pdf, apos exportar) Sheets("plan1").Select End Sub

Pra mim aqui funcionou direitinho. Realmente não sei te dizer sem ver sua plan. Verifique se procedeu a alteração do cod corretamente. Quanto ao botão voce pode substitui-lo por um atalho de teclado. Altere no nome da sub: Private Sub CommandButton1_Click() -> para Public Sub CommandButton1_Click() volte a planilha aperte ALT + F8 e selecione a respectiva macro e na janela em opções escolha uma tecla, de preferência a letra "q" ou "w" abx.

Guilherme, se tivesse incluido esta informação, já teria resolvido Por favor, substitua esta linha no codigo: Set myCel = ActiveSheet.Range("F15") ' AQUI: Altere a cel. desejada Por esta: Set myCel = ActiveCell abx.

Pelo que entêndi voce quer que a imagem se ajustasse (Larg/ Alt.), a uma determinada celula:. Na alteração do codigo, macro vai inserir na celula F15. Altere de acordo c/ sua necessidade: Private Sub CommandButton1_Click() Dim profile As String On Error GoTo 0 Dim fd As FileDialog Dim myCel As Range Set myCel = ActiveSheet.Range("F15") ' AQUI: Altere a cel. desejada Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Filters.Clear .Filters.Add "Picture Files", "*.bmp;*.jpg;*.gif;*.png" .ButtonName = "Select" .AllowMultiSelect = False .Title = "Choose Photo" .InitialView = msoFileDialogViewDetails .Show End With ActiveSheet.Range("E3").Select With ActiveSheet.Pictures.Insert(fd.SelectedItems(1)) i = 17 .Left = myCel.Left .Top = myCel.Top .Placement = 1 .PrintObject = True profile = .Name End With ActiveSheet.Pictures(profile).Select With Selection.ShapeRange .LockAspectRatio = msoFalse .Width = myCel.Width .Height = myCel.Height End With End Sub

Como assim fazer em um modulo? voce pode usar um unico modulo e escrever( criar ) varias macros. Tente assim: While Not r.EOF r.Edit If Pr > 60 Then Pdr = "Não" Else Pdr = "Sim" End If r.Update r.MoveNext Wend

Veja se é isso: se for <= a 60 -> SIM; se for > a 60 -> NAO: abx. Sub Calcular_Meses() Dim d As Database Dim r As Recordset Dim DtI As Field, DtF As Field, Pr As Field, Dpf As Field Dim Pdr As Field Set d = CurrentDb() Set r = d.OpenRecordset("tabela1") Set DtI = r.Fields("Data inicial") Set DtF = r.Fields("Data Final") Set Pr = r.Fields("Prazo") Set Dpf = r.Fields("Dias") Set Pdr = r.Fields("Passível de Renovação") While Not r.EOF r.Edit DtF = DateAdd("m", Pr, DtI) Dpf = DateDiff("d", Date, DtF) Select Case Pr Case Is > 60 Pdr = "NÃO" Case Is <= 60 Pdr = "SIM" End Select r.Update r.MoveNext Wend r.Close End Sub

Andersonbu, desconheço que o excel tenha esse recurso que quer. Uma forma de fazer isso, seria com o vba. Veja este exemplo que baixei na net há algum tempo (creditos no editor vba), acho que atende o que quer. abx. CTRL L EM VBA.xls

Substitua o cod abaixo no mod 1: * os valores (-) negativos que retornarêm no campo 'Dias para o fim' representam em "dias vencidos. " abx. Option Compare Database Sub Calcular_Meses() Dim d As Database Dim r As Recordset Dim DtI As Field, DtF As Field, Pr As Field, dpf As Field Set d = CurrentDb() Set r = d.OpenRecordset("tabela1") 'Altere os nomes: (tabela,campos) Set DtI = r.Fields("Data inicial") Set DtF = r.Fields("Data Final") Set Pr = r.Fields("Prazo") Set dpf = r.Fields("Dias para o fim") While Not r.EOF r.Edit DtF = DateAdd("m", Pr, DtI) dpf = DateDiff("d", Date, DtF) r.Update r.MoveNext Wend r.Close End Sub

Deyvisson bom dia, Eu já havia postado anteriormente um exemplo, atendendo a uma situação parecida a sua: http://forum.clubedohardware.com.br/forums/topic/1103827-planilha-com-datas/ Infelizmente o colega, não quis usar a seu favor o poder da programação e preferiu fazer tudo manualmente (a criação das centenas de 'abas') e usar formulas para obter os dados a cada 'aba'. Mas vamos lá, voltando ao seu caso, como voce não postou um modelo ou exemplo, criei um com os dados que informou, veja e consegue se adaptar, ou adaptar o codigo a seu cenário: No modelo que anexei: Aperte o botão para executar a macro. Em qualquer aba que estiver, aperte ( CLTR + q ), para retornar a aba (tela de cadastro) A macro em questão, verifica se existir ou não, e cria uma nova plan (aba) renomeando de acordo com o mes (coluna A desta aba), em seguida copia a linha toda com os dados para a respectiva aba. Na (coluna E), é criado uma chave (uma serial unica), para que a macro verifique se o registro já existe ou nao na aba do respect. mes. * SE QUISER PODE OCULTAR ESTA COLUNA Na (coluna F), é criado em cada linha, um atalho automatico, para que possa acessar a aba em que está o respect. registro.: abx. Sub Verif_EnvRg_Abas() Dim sh As Worksheet, Pla As Boolean Dim Mes As String, chv As String Dim rng As Range, C As Range, rngNC As Range Dim i As Long: i = 2 Dim ct As String: ct = 0 Dim rg As String: rg = 0 With Sheets("Tela de Cadastro") .Activate Application.DisplayAlerts = False For i = i To Range("a" & Rows.Count).End(xlUp).Row If .Range("a" & i).Value = "" Then GoTo px Mes = Trim(UCase(Left(.Range("a" & i).Value, 1)) & Mid(.Range("A" & i), 2)) Set rng = .Range(.Cells(i, "a"), .Cells(i, "e")) Set rngNC = .Range(.Cells(1, "a"), .Cells(1, "e")) chv = .Range("a" & i).Value & .Range("b" & i).Value & .Range("c" & i).Value & .Range("d" & i).Value .Range("e" & i).Value = chv For Each sh In Worksheets If sh.Name Like Mes Then Pla = True: Exit For Next If Pla = True Then uld = Sheets(sh.Index).Range("a" & Rows.Count).End(xlUp).Row + 1 Set C = Sheets(sh.Index).Range("e2:e" & uld).Find(chv, , LookIn:=xlValues, Lookat:=xlWhole) If C Is Nothing Then Sheets(sh.Index).Range("a1:e1").Value = rngNC.Value Sheets(sh.Index).Range("a" & uld & ":e" & uld) = rng.Value .Range("f" & i).FormulaR1C1 = "=HYPERLINK(""[" & ThisWorkbook.Name & "]" & Mes & "!A1"",""CLICK AQUI"")" rg = rg + 1 End If Else Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = Mes ActiveSheet.Range("a1:e1").Value = rngNC.Value uld = ActiveSheet.Range("a" & Rows.Count).End(xlUp).Row + 1 ActiveSheet.Range("a" & uld & ":e" & uld) = rng.Value .Range("f" & i).FormulaR1C1 = "=HYPERLINK(""[" & ThisWorkbook.Name & "]" & Mes & "!A1"",""CLICK AQUI"")" ct = ct + 1 rg = rg + 1 End If Pla = Falsepx: Next i .Activate MsgBox ct & " Plan(abas) novas foram criadas" & Chr(10) & rg & " Registros copiados", 0, " Sucesso" End WithEnd Sub Tela de cadastro-Exemplo.zip

Higor, como voce não compartilhou sua tabela ou um exemplo, Segue um exemplo em vba por suposicâo: Aperte ALT + F11, crie um modulo e cole o codigo abaixo, em seguida exceute a macro. Sub Calcular_Meses() Dim d As Database Dim r As Recordset Dim DtI As Field, DtF As Field, Pr As Field Set d = CurrentDb() Set r = d.OpenRecordset("tabela1") 'Altere os nomes: (tabela,campos) Set DtI = r.Fields("Data inicial") Set DtF = r.Fields("Data Final") Set Pr = r.Fields("Prazo") While Not r.EOF r.Edit DtF = DateAdd("m", Pr, DtI) r.Update r.MoveNext Wend r.Close End Sub Database1.zip

Bom dia Jonatas, Se voce nao postar um exemplo para quem vai ajudar veja os endereços das colunas, acho difícil voce conseguir uma solução.

Hanarge, faltou voce indicar a coluna em que estarão os end de emails. E quer enviar anexos tbem? Se puder, faça um upload de um modelo de sua planilha com essas informações incluidas, facilita o retorno da breve da solução.

ops. veja agora: Private Sub btnexcluir_Click() Dim sh As Worksheet Set sh = Sheets("plan3") With sh .Range("a2").Activate For cont = 1 To 1000 If ActiveCell = txtnome.Text Then resposta = MsgBox("Deseja excluir cliente?", 3, "Excluir Cliente") End If If resposta = vbYes Then ActiveCell.EntireRow.Delete End If ActiveCell.Offset(1, 0).Activate Next .Range("A2").Activate End With End Sub