Oficina da Net Logo

10 melhores VBAs para turbinar o Excel

Veja os 10 melhores códigos para incrementar seu Excel e tornar as tarefas diárias ainda mais produtivas, eficientes e divertidas.

Por | @Evilmaax Excel 2 comentários

Sabia que os programas do pacote Office podem receber códigos para que possam fazer qualquer coisa que você imaginar? Você pode criar um código para a planilha do Excel executar em determinado momento do dia; para o seu arquivo do Word lhe dar "bom dia". "boa tarde" ou "boa noite" quando executar o arquivo, etc.

Para aproveitar dessas funcionalidades não tem mistério. Só criar uns codigosinhos e pronto. Não sabe como criar os códigos? Sem problemas, pois vou dar eles prontinhos para você =D

Os códigos foram escolhidos do nosso site parceiro Aprender Excel e lá tem muuuuito mais do que 10. Então passe lá depois para ver tudo que não coube nessa lista. Tem até um curso de desenvolvimento e programação VBA

Mas antes de começarmos precisamos ter algumas noções básicas sobre VBA:

Leia em destaque: Tabela Copa do Mundo 2018 no Excel.

  • Para entrar no ambiente de edição você deverá apertar o atalho alt + F11 no seu Excel;
  • No ambiente de edição atente para as diferenças entre módulo, pasta de trabalho e planilha. Esse detalhe fará toda a diferença entre um código que funciona e um código que dá erro.
  • Aqui neste post você verá os códigos a serem inseridos e a explicação de sua utilidade. Se ficar com dúvidas de como fazer para inseri-lo corretamente é só clicar no título da macro e você será direcionado para o post do site Aprender Excel onde contará com um passo a passo detalhado para cada código. 
  • Aqui há uma explicação mais aprofundada para quem precisa de noções básicas sobre criar comandos em VBA.

Antes de começarmos a ver a listagem, algumas dicas:

Alguns códigos como o de prazo de validade não precisam "ser chamados", eles rodam automaticamente a cada vez que a planilha for iniciada, já alguns outros você terá de colocar em botões. Assim, o usuário clica no botão e a macro é disparada. Não sabe como criar botões? Eu te ensino neste link. É bem fácil. 

Como disse acima existem módulo, pasta de trabalho planilha e cada um tem sua especificidade. Se você estiver utilizando um módulo, por exemplo, não será possível colocá-lo no botão como acabamos de aprender. Será preciso uma "função chamadora". Mas não se preocupe, a função chamadora está no post original que você confere clicando no título do VBA. 

E caso você esteja se perguntando, sim, é possível mesclar diversos códigos para criar uma super planilha megazord com a união de diversar ferramentas =D Quer um exemplo? Confira esta planilha de prazo de validade que tem diversos códigos de segurança mesclados como a remoção do copiar e colar, a remoção do salvar como, a exclusão automática, etc. 

E por fim o último e mais importante detalhe, principalmente para as macros de segurança. Funciona assim: Como as VBAs podem conter códigos maliciosos, o Windows, por segurança, as mantém bloqueadas até que o usuário as habilite. Isso pode ser muito ruim, pois imagine a situação: Você faz uma planilha com a macro que proíbe a cópia de conteúdo, afinal, possui dados que você não quer que sejam distribuídos por aí, mas, o usuário não ativa as macros, e, com isso, pode copiar o que quiser. Não serviu de nada a VBA, certo?

Por isso vamos usar este método para forçar o usuário a ativar as macros.

Agora sim, vamos ao top 10 de códigos VBA para seu Excel.

Criando um calendário mensal ou anual

Calendários parecem ser uma das funções mais utilizadas do Excel, pois os posts com essa temática sempre fazem bastante sucesso, além de serem um dos temas mais recorrentes entre os pedidos dos leitores. Por isso nada mais justo do que começar com o código para sua criação. 

Na verdade são 2 códigos (mas vamos contar apenas como 1 para a lista ficar maior :D ) Um deles cria calendários mensais e outro cria um calendário anual. Escolha o seu preferido e seja feliz. 

Para a versão anual o código a ser colado no módulo é esse:

Option Explicit 
    Sub CriarCalendario()
    Dim lMonth As Long
    Dim strMonth As String
    Dim rStart As Range
    Dim strAddress As String
    Dim rCell As Range
    Dim lDays As Long
    Dim dDate As Date
    Dim lPositionCell As Integer
    Dim bEscreveData As Boolean
    Dim lYear As Integer
    Dim sYear As String

'Solicita o Ano para montar o calendário
    
   sYear = InputBox("Informe o Ano para gerar o calendário:", "Criar Calendário", Year(Date))

'Sai da rotina se não for informado um ano válido
  
   If (sYear = "" Or Not IsNumeric(sYear)) Then Exit Sub
   lYear = CInt(sYear)

'Adiciona uma nova Planilha para criar o calendário
   Worksheets.Add
   ActiveSheet.Name = "Calendário " & lYear
                    'Ocultar as linhas de grade
   ActiveWindow.DisplayGridlines = False
                    'Formata as colunas
   With Cells
      .ColumnWidth = 6
      .Font.Size = 8
   End With

'Cria o cabeçalho para os meses
   For lMonth = 1 To 12 Step 3
   Select Case lMonth
       Case 1
             Set rStart = Range("A1")
       Case 4
             Set rStart = Range("A9")
        Case 7
             Set rStart = Range("A17")
        Case 10
             Set rStart = Range("A25")
   End Select

   strMonth = MonthName(lMonth) 'Atribui o nome do mês na variável

'Mescla, auto-preenche e alinha os blocos dos meses

   With rStart
      .Value = UCase(strMonth)
      .HorizontalAlignment = xlCenter
      .Interior.ColorIndex = 6
      .Font.Bold = True
   With .Range("A1:G1")
      .Merge
      .BorderAround LineStyle:=xlContinuous
   End With

'Preenche o cabeçalho dos dias da semana
   For lDays = 1 To 7
      .Cells(2, lDays).Value = UCase(WeekdayName(lDays, True))
   Next lDays
      .Range("A2:G2").BorderAround LineStyle:=xlContinuous 
                      'Auto preenche demais meses ao lado
       .Range("A1:G2").AutoFill Destination:=.Range("A1:U2")
   End With
   Next lMonth

'Preenche os meses com seus respectivos dias
   
For lMonth = 1 To 12
   strAddress = Choose(lMonth, "A3:G8", "H3:N8", "O3:U8", _
            "A11:G16", "H11:N16", "O11:U16", _
            "A19:G24", "H19:N24", "O19:U24", _
            "A27:G32", "H27:N32", "O27:U32")
    lDays = 0
    lPositionCell = 0
    bEscreveData = False
    Range(strAddress).BorderAround LineStyle:=xlContinuous
                       'Adiciona os dias
    For Each rCell In Range(strAddress)
    lDays = lDays + 1
    lPositionCell = lPositionCell + 1
    dDate = DateSerial(lYear, lMonth, lDays) 

    If bEscreveData = False Then
    If Weekday(dDate, vbSunday) = lPositionCell Then
    bEscreveData = True
  Else
    bEscreveData = False
   lDays = 0

 End If
 End If

   If bEscreveData = True Then
   If Month(dDate) = lMonth Then 'Se for uma data válida
   With rCell
        .Value = dDate
        .NumberFormat = "dd"
  End With

End If
End If

   Next rCell
   Next lMonth

'Formatação condicional para o dia de hoje.

   With Range("A1:U32")
       .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=HOJE()"
       .FormatConditions(1).Font.ColorIndex = 2
       .FormatConditions(1).Interior.ColorIndex = 11
       .HorizontalAlignment = xlCenter
   End With

End Sub

e o resultado é esse:

Se você quiser criar um calendário mensal o código a ser inserido em Esta_pasta_de_trabalho será esse:

Sub CalendarioMensal()    

   ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
   Scenarios:=False
   Application.ScreenUpdating = False
   On Error GoTo MyErrorTrap
   Range("a1:g14").Clear 

'Esta será a área onde será inserido o calendário. Se você editar a área de inserção não esqueça de editar as células abaixo para não dar erro

MyInput = InputBox("Digite o mês e o ano do seu calendário:" & vbCrLf & "" & vbCrLf & "www.AprenderExcel.com.br")
    If MyInput = "" Then Exit Sub
       StartDay = DateValue(MyInput)
        If Day(StartDay) <> 1 Then
        StartDay = DateValue(Month(StartDay) & "/1/" & _
        Year(StartDay))
    End If

Range("a1").NumberFormat = "mmmm yyyy"

With Range("a1:g1")
    .HorizontalAlignment = xlCenterAcrossSelection
    .VerticalAlignment = xlCenter
    .Font.Size = 18
    .Font.Bold = True
    .RowHeight = 35
End With

With Range("a2:g2")
    .ColumnWidth = 11
    .VerticalAlignment = xlCenter
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Orientation = xlHorizontal
    .Font.Size = 12
    .Font.Bold = True
    .RowHeight = 20
End With

Range("a2") = "Domingo"
Range("b2") = "Segunda"
Range("c2") = "Terça"
Range("d2") = "Quarta"
Range("e2") = "Quinta"
Range("f2") = "Sexta"
Range("g2") = "Sábado"

With Range("a3:g8")
   .HorizontalAlignment = xlRight
   .VerticalAlignment = xlTop
   .Font.Size = 18
   .Font.Bold = True
   .RowHeight = 21
End With

Range("a1").Value = Application.Text(MyInput, "mmmm yyyy")
DayofWeek = Weekday(StartDay)
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)

Select Case DayofWeek
   Case 1
   Range("a3").Value = 1
   Case 2
   Range("b3").Value = 1
   Case 3
   Range("c3").Value = 1
   Case 4
   Range("d3").Value = 1
   Case 5
   Range("e3").Value = 1
   Case 6
   Range("f3").Value = 1
   Case 7
   Range("g3").Value = 1
End Select

For Each cell In Range("a3:g8")
   RowCell = cell.Row
   ColCell = cell.Column
     If cell.Column = 1 And cell.Row = 3 Then
     ElseIf cell.Column <> 1 Then
          If cell.Offset(0, -1).Value >= 1 Then
            cell.Value = cell.Offset(0, -1).Value + 1
               If cell.Value > (FinalDay - StartDay) Then
               cell.Value = ""
               Exit For
           End If
     End If
   ElseIf cell.Row > 3 And cell.Column = 1 Then
      cell.Value = cell.Offset(-1, 6).Value + 1
         If cell.Value > (FinalDay - StartDay) Then
         cell.Value = ""
       Exit For
    End If
 End If
Next

For x = 0 To 5
Range("A4").Offset(x * 2, 0).EntireRow.Insert
     With Range("A4:G4").Offset(x * 2, 0)
         .RowHeight = 65
         .HorizontalAlignment = xlCenter
         .VerticalAlignment = xlTop
         .WrapText = True
         .Font.Size = 10
         .Font.Bold = False
         .Locked = False
      End With
      With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlLeft)
         .Weight = xlThick
         .ColorIndex = xlAutomatic
      End With
      With Range("A3").Offset(x * 2, 0).Resize(2, 7).Borders(xlRight)
         .Weight = xlThick
         .ColorIndex = xlAutomatic
      End With

Range("A3").Offset(x * 2, 0).Resize(2, 7).BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
Next
      If Range("A13").Value = "" Then Range("A13").Offset(0, 0) _
          .Resize(2, 8).EntireRow.Delete
          ActiveWindow.DisplayGridlines = False

' ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ Atenção: 

' Se você quiser bloquear seu calendário contra edições é só apagar as aspas vermelhas no início dessa frase e na frase abaixo

' Scenarios:=True
ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = True

Exit Sub

MyErrorTrap:
    MsgBox "Provavelmente você não entrou os dados corretamente" _
    & Chr(13) & "" _
    & Chr(13) & "Digite o nome do mês" _
    & " (você pode usar a abreviação de 3 letras)" _
    & Chr(13) & "e 4 dígitos para o ano" _
    & Chr(13) & "" _
    & Chr(13) & "www.AprenderExcel.com.br"
    MyInput = InputBox("Digite o mês e o ano")
    If MyInput = "" Then Exit Sub
Resume

End Sub

E o resultado será esse:

Fazendo um cronômetro VBA

Precisa controlar alguma tarefa com precisão? Precisar criar uma planilha que necessita medir o tempo empregado? Pois esse cronômetro em VBA vai resolver todos os seus problemas. 

No módulo você irá inserir:

Sub iniciar_crono()

      If Plan1.Buttons(1).Text = "Stop" Then

                 If Range("j4").Value = "" Then
                     Range("j4").Value = Time
                     Range("l3").Select
                     Selection.Copy
                     Range("k4").Select
                     ActiveSheet.Paste
                     Range("k4").Formula = "=j4-i4"
                  Else
                     Range("j3").End(xlDown).Offset(1, 0).Value = Time
                     Range("k3").End(xlDown).Select
                     Selection.Copy
                     Selection.Offset(1, 0).Select
                     ActiveSheet.Paste

                 End If

                 Plan1.Buttons(1).Text = "Start"
     Else
                 If Range("i4").Value = "" Then
                     Range("i4").Value = Time
                 Else
                     Range("i3").End(xlDown).Offset(1, 0).Value = Time
                 End If

                 Plan1.Buttons(1).Text = "Stop"

     End If

End Sub

Veja o resultado apís a adição de uma imagem de fundo e alguma personalização:

 

Fazer com que a planilha só abra em 1 computador

E já que o negócio é segurança vamos complicar ainda mais para os xeretas. Com o código abaixo a sua planilha só vai poder ser aberta no computador especificado. Não tem prazo ou qualquer outro tipo de validação, apenas o nome da máquina. 

Ahh, e claro que você pode mesclar com o código de exclusão, por exemplo.

Para usufruir da verificação de máquina no Excel cole o seguinte código no Módulo

Public Sub Verificar()
     
   Dim CompName As String

   CompName = Environ$("ComputerName")

'Aqui você irá colocar o nome da máquina autorizada
      If CompName <> "PC_Max" Then 

'Mensagem de erro exibida se o nome não bater
        MsgBox "Este computador não tem direito de executar esta aplicação."
        ActiveWorkbook.Close SaveChanges:=False

      End If

End Sub

Confira o resultado com a frase que eu determinei:

 

Realçando a célula ativa (método 1 - método 2)

Você é daqueles que costumam criar relatórios imensos, mantém e edita planilha enormes e repleta de dados, que tem incontáveis células preenchidas, etc ? Por isso você precisa ir e vir, subir e descer na planilha procurando a célula certa e quando vê já está perdido? Já nem sabe mais aonde está o cursor?

Então essa aula é para você. Temos 2 métodos que nunca mais vão deixar você se perder por entre os dados.

O primeiro deles deve ser inserido diretamente no código da planilha

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    
'*** Definição de variáveis ***
   
h = ActiveCell.Height
w2 = ActiveCell.Width
t = ActiveCell.Top
w = ActiveCell.Left

'Testa se os retangulos shapes são existentes.

  On Error Resume Next
  ActiveSheet.Shapes("RectangleV").Delete
  On Error Resume Next

ActiveSheet.Shapes("RectangleH").Delete

'Ajuste dos shapes retangulos

ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, t, w, h).Name = "RectangleV"

  With ActiveSheet.Shapes("RectangleV")
     .Fill.Visible = msoFalse
     .Fill.Transparency = 20#
     .Line.Weight = 2#
     .Line.ForeColor.SchemeColor = 10
     .PrintObject = False
  End With

ActiveSheet.Shapes.AddShape(msoShapeRectangle, w, 0, w2, t).Name = "RectangleH"

  With ActiveSheet.Shapes("RectangleH")
     .Fill.Visible = msoFalse
     .Fill.Transparency = 20#
     .Line.Weight = 2#
     .Line.ForeColor.SchemeColor = 10
   End With

End Sub

O resultado é esse:

Já o segundo método (que eu acho melhor) também deve ser colado diretamente no código da planilha e é este daqui:

Dim lTarget As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
If Not lTarget Is Nothing Then

   lTarget.Interior.ColorIndex = 0
   
End If

Target.Interior.ColorIndex = 6

Set lTarget = Target

End Sub

Para aprender a mudar as cores de realce, tanto do método 1 como do método 2, acesse os referidos posts, pois lá estamos explicando. 

 

Prazo de validade da planilha

Muito dos usos dos códigos VBA são para aumentar a segurança dos seus dados. Um bom exemplo da programação no Excel para estes fins é este daqui.

Com ele você poderá definir uma data limite para que o arquivo seja fique disponível. Depois que o dia limite for atingido a planilha não abrirá. Fácil assim. 

O código é bem simples e deve ser colado em EstaPasta_de_trabalho. Repare para o campo onde você especifica a data limite e a mensagem a ser exibida se o arquivo tiver expirado.

Private Sub Workbook_Open()

Application.EnableCancelKey = xlDisabled
Dim dt As Date

'Escolha a data em a Pasta de Trabalho deverá expirar (ano, mês, dia)
     
dt = DateSerial(2017, 12, 31)

 If Date >= dt Then
     MsgBox "Esta Pasta de Trabalho expirou! Favor contatar o administrador."
 
 ThisWorkbook.Close SaveChanges:=False

  End If

End Sub

 

VBA para excluir a planilha antes ou após seu uso

Mais um código voltado à segurança. Quer enviar para seu amigo uma planilha que se exclua automaticamente após o uso? Então é só usar este código. Detalhe: O arquivo não vai nem para a lixeira, é excluído mesmo!!

Além disso você pode mesclar com o código anterior, onde definimos uma data de validade. Por exemplo, assim que a data for atingida a planilha se exclui. Legal, não? Com algumas alterações isto pode ser feito. Aliás, ela já foi feita pelo pessoal do Aprender Excel e pode ser baixada gratuitamente neste endereço.

Agora sim, vamos ao código. Ele deverá ser incluído em EstaPasta_de_trabalho:

Private Sub Workbook_BeforeClose (Cancel As Boolean)
Dim dtexp As Date
  
     dtexp = ("29/04/2011")
  
     If Date >= #1/11/2010# Then
     If Date >= dtexp Then
  
     ThisWorkbook.Saved = True
  
'personalize a mensagem na linha abaixo
     MsgBox "Este arquivo se autoexcluirá pois você só tem direito à 1 execução"         
  
     ThisWorkbook.ChangeFileAccess xlReadOnly
  
     Kill ThisWorkbook.FullName
          
     End If
     End If
  
End Sub

Mas e se você quer um código que garante que a planilha não poderá ser aberta após a data limite ter sido alcançada e que se exclua na tentativa de abertura? Ou seja a planilha nem será visualizada, pois vai sumir ANTES de ser aberta e exibida.

Neste caso é só colar o seguinte código em EstaPasta_de_trabalho

Private Sub Workbook_Open()
Dim dtexp As Date
  
'Escolha a data que deverá expirar
     dtexp = ("29/04/2011")
  
     If Date >= #1/11/2010# Then
     If Date >= dtexp Then
  
     ThisWorkbook.Saved = True
  
'personalize a mensagem na linha abaixo
     MsgBox "Este arquivo está expirado, se autoexcluirá!"         
  
     ThisWorkbook.ChangeFileAccess xlReadOnly
  
     Kill ThisWorkbook.FullName
     ThisWorkbook.Close
          
     End If
     End If
  
End Sub

O resultado é esse:

 

Alternando entre células determinadas

Sabe quando você cria uma planilha de cadastro qualquer (como essa de pessoas) e tem diversas células a serem preenchidas?

Com este código você poderá determinar que o Excel alterne entre as células definidas assim que o usuário preencher o campo e der um enter. Funciona assim: Digamos que seu formulário contenha as células A5, B8 e E9, após ele inserir o valor em A5 e confirmar, o cursor irá automaticamente para a próxima célula editável, no caso, B8.

Continua confuso? Não se preocupe, pois depois do código a ser inserido diretamente na planilha

Private Sub Worksheet_Change(ByVal Target As Range)

   On Error GoTo z
   Application.EnableEvents = False If Not Intersect(Target, Range("célula onde o usuário irá inserir o valor")) Is Nothing Then [próxima célula onde o Excel irá automaticamente].Activate

   End If Continue:
   Application.EnableEvents = True
   Exit Sub
   z:
   MsgBox Err.Description
   Resume Continue

End Sub

Na prática é só você repetir a parte abaixo para cada célula a ser alternada automaticamente:

If Not Intersect(Target, Range("célula onde o usuário irá inserir o valor")) Is Nothing Then
[próxima célula onde o Excel irá automaticamente].Activate

Lá na página do código você confere certinho como fazer e replicar para várias células. E agora, como prometido, o código em prática:

 

VBA que faz login automático em sites

Com esse código você vai aprender a criar uma planilha que faz login automaticamente em qualquer site. Esse recurso pode ser útil para você mesclar, por exemplo, com o recurso de importar dados da web diretamente para o Excel.

O código a seguir será colado em um módulo, mas antes temos que adicionar uma biblioteca suplementar ao Excel.

Para isso vamos abrir a janela de edição de códigos com o atalho alt + f11 e depois vá em 'Ferramentas' e 'Referências'. Será aberta uma nova janela onde marcaremos a opção 'Microsoft Internet Controls' e a opção 'Microsoft HTML Object Library'. Dê um 'ok'.

Agora insira o módulo e cole o seguinte código:

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer

Sub Login()

   Dim oHTML_Element As IHTMLElement
   Dim sURL As String
   On Error GoTo Err_Clear
      sURL = "site do login"
   Set oBrowser = New InternetExplorer
      oBrowser.Silent = True
      oBrowser.timeout = 60
      oBrowser.Navigate sURL
      oBrowser.Visible = True

Do
Loop Until oBrowser.ReadyState = READYSTATE_COMPLETE

   Set HTMLDoc = oBrowser.Document
     HTMLDoc.all.id de Email.Value = "seu e-mail"
     HTMLDoc.all.id de senha.Value = "sua senha"

For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
    If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For

Next
   Err_Clear:

Resume Next

End Sub

Veja eu abrindo o Facebook pelo Excel e logando automaticamente através dele. 

P.S. É extremamente importante que você leia a aula completa desse código, pois lá você aprenderá a identificar os campos e variáveis necessárias para o funcionamento do código. Cada site tem seus nomes de variáveis específicos!!

 

Enviando e-mail diretamente do Excel

Sempre digo que o Excel não para de nos surpreender, pois sempre aprendemos algo que nem mesmo imaginávamos ser possível como, por exemplo, mandar e-mail diretamente do Excel. E digo mais: Diretamente MESMO, sem uso de Outlook ou qualquer outra ferramenta que não mesmo o próprio Excel.

E antes que você se pergunte um exemplo de aplicação desta técnica, clique aqui e confira uma planilha de backup local que é enviada diretamente para seu e-mail. Um outro exemplo é uma planilha de mailing que você pode conferir aqui.

O primeiro passo caso você deseje enviar e-mail pelo seu Excel é ir até 'Ferramentas', depois 'Referências' e adicionar a biblioteca 'Microsoft CDO for Windows 2000 Library'. Marque e dê o OK.

Depois insira um módulo e cole o seguinte código:

Function EnviaEmail()

Dim iMsg, iConf, Flds
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

 schema = "http://schemas.microsoft.com/cdo/configuration/"
 Flds.Item(schema & "sendusing") = 2
 'Configura o smtp
 Flds.Item(schema & "smtpserver") = "smtp.gmail.com"
 'Configura a porta de envio de email
 Flds.Item(schema & "smtpserverport") = 465
 Flds.Item(schema & "smtpauthenticate") = 1
 'Configura o email do remetente
 Flds.Item(schema & "sendusername") = "maximilianomeyer48@gmail.com"
 'Configura a senha do email remetente
 Flds.Item(schema & "sendpassword") = "senha do seu e-mail"
 Flds.Item(schema & "smtpusessl") = 1
 Flds.Update

With iMsg
   'Email do destinatário
   .To = "max@desenvolveweb.com.br"
   'Seu email
   .From = "exemplo@gmail.com"
   'Título do email
   .Subject = "Isto é um teste de Envio de e-mail"
   'Mensagem do e-mail, você pode enviar formatado em HTML
   .HTMLBody = "Mensagem enviada com o gmail"
   'Seu nome ou apelido
   .Sender = "Teste"
   'Nome da sua organização
   .Organization = "Aprender Excel"
   'e-mail de responder para
   .ReplyTo = "maximilianomeyer48@gmail.com"
   'Anexo a ser enviado na mensagem. Retire a aspa da linha abaixo e coloque o endereço do arquivo
   .AddAttachment ("c:/fatura.txt")
   Set .Configuration = iConf
   .Send
End With

Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing

End Function

Sub disparar()

   EnviaEmail
   MsgBox "O e-mail foi disparado com sucesso!", vbOKOnly, "e-mail enviado"

End Sub

Mas é sério, esse tutorial é um dos que mais possuem detalhes para que tudo funcione do jeito pretendido. Então confira o link original do post

k

 

VBA para listar todos os arquivos de uma pasta no Excel

E para finalizar uma VBA para quem cria planilhas mais complexas e que vai interagir com outras funções da sua máquina. Com este código isso a sua planilha vai poder exibir o conteúdo de qualquer pasta do seu pc. Mescle o código com uma VBA para chamar o salvar como e já era. 

Veja o código que vamos colar no local 'EstaPasta_de_trabalho'

Sub Lista_Arquivos_nas_pastas()

   Dim RootFolder$
   RootFolder = Localiza_Dir
      If RootFolder = "" Then Exit Sub
      Workbooks.Add
         With Range("A1")
            .Formula = "Arquivos do Diretório: " & RootFolder
            .Font.Bold = True
            .Font.Size = 12
         End With
     Range("A3").Formula = "Caminho: "
     Range("B3").Formula = "Nome: "
     Range("C3").Formula = "Data Criação: "
     Range("D3").Formula = "Data último Acesso: "
     Range("E3").Formula = "Data última Modificação: "
         With Range("A3:E3")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
         End With
   ListFilesInFolder RootFolder, True
   Columns("A:H").AutoFit
End Sub

Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
   Dim FSO As Scripting.FileSystemObject
   Dim SourceFolder As Scripting.Folder
   Dim SubFolder As Scripting.Folder
   Dim FileItem As Scripting.File
   Dim r As Long
   Set FSO = CreateObject("Scripting.FileSystemObject")
   Set SourceFolder = FSO.GetFolder(SourceFolderName)
   r = Range("A65536").End(xlUp).Row + 1
   For Each FileItem In SourceFolder.Files
   Cells(r, 1).Formula = FileItem.ParentFolder
   Cells(r, 2).Formula = FileItem.Name
   Cells(r, 3).Formula = FileItem.DateCreated
   Cells(r, 3).NumberFormatLocal = "dd / mm / aaaa"
   Cells(r, 4).Formula = FileItem.DateLastAccessed
   Cells(r, 5).Formula = FileItem.DateLastModified
   Cells(r, 5).NumberFormatLocal = "dd / mm / aaaa"
   r = r + 1
   Next FileItem
   If IncludeSubfolders Then
      For Each SubFolder In SourceFolder.SubFolders
         ListFilesInFolder SubFolder.Path, True
         Next SubFolder
    End If
   Set FileItem = Nothing
   Set SourceFolder = Nothing
   Set FSO = Nothing
   ActiveWorkbook.Saved = True
End Sub

Private Function Localiza_Dir()
   Dim objShell, objFolder, chemin, SecuriteSlash
   Set objShell = CreateObject("Shell.Application")
   Set objFolder = _
   objShell.BrowseForFolder(&H0&, "Procurar por um Diretório", &H1&)
   On Error Resume Next
   chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & ""
   If objFolder.Title = "Bureau" Then
      chemin = "C:WindowsBureau"
   End If
   If objFolder.Title = "" Then
      chemin = ""
   End If
   SecuriteSlash = InStr(objFolder.Title, ":")
   If SecuriteSlash > 0 Then
      chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
   End If
Localiza_Dir = chemin

End Function

Veja o resultado:

y

 

Hey, acompanhe todas as notícias do Oficina da Net no Telegram. Inscreva-se grátis.

MAIS SOBRE: #excel  #planilha  #office
Comentários
Carregar comentários