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:
- 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.
[CURSO]116[/CURSO]
Como disse acima existem módulo, pasta de trabalho e 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 Sube 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 SubE 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 SubVeja 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 SubConfira 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 SubO 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 SubPara 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 SubMas 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 SubO 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 SubNa 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].ActivateLá 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 SubVeja 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") = "[email protected]"
'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 = "[email protected]"
'Seu email
.From = "[email protected]"
'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 = "[email protected]"
'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.
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😕 Poxa, o que podemos melhorar?
😃 Boa, seu feedback foi enviado!
✋ Você já nos enviou um feedback para este texto.
