Basole

@Bianca Chagas  No arquivo Excel, na clouna "G" acrescente todos os endereços (caminho), das fotos que serão inseridas na apresentação do arquivo PowerPoint.
* Feche o arquivo do Excel
Para Executar a macro, no arquivo PowerPoint, aperte as teclas Alt+ F8, em seguida click 2 vezes na macro "MalaDiretaComExcel" e aguarde. 
 
 
MalaDiretaPPT.zip

Segue com as alterações
 
 
VBA CONFORME O DIA DA SEMANA APRESENTAR O NOME DO PROFESSOR - PERG.zip

@isabela queirozVeja se o exemplo atende
 
 
 
Salvar_Sheet_Novo_Arquivo.zip

@JorgeSouza coloque o prefixo VBA.  em todas funções:
 
Vba.Format
VBA.Ucase
VBA. DateAdd
 
 
 

Tente 
 
Range("H11").value = Range("H11").value * 1.01 
 
Para 1% e 
 * 1.005
para 0,5 %

@Andreza Santos
 
Fiz alterações na sub Inserir_Clientes
 
Sub Inserir_clientes() Dim tabela_clientes As ListObject Dim n As Integer Dim id As Integer Dim ws As Worksheet Set ws = Sheets("Clientes") Set tabela_clientes = ws.ListObjects("Clientes") id = Range("ID").Value With tabela_clientes .ListRows.Add n = .DataBodyRange.Columns(1).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row .DataBodyRange(RowIndex:=n, columnindex:=1).Value = id .DataBodyRange(RowIndex:=n, columnindex:=2).Value = Sistema.txt_nome.Value .DataBodyRange(RowIndex:=n, columnindex:=3).Value = Sistema.cbb_sexo.Value .DataBodyRange(RowIndex:=n, columnindex:=4).Value = Sistema.txt_telefone.Value .DataBodyRange(RowIndex:=n, columnindex:=5).Value = Sistema.txt_cep.Value .DataBodyRange(RowIndex:=n, columnindex:=6).Value = Sistema.txt_endereco.Value .DataBodyRange(RowIndex:=n, columnindex:=7).Value = Sistema.txt_numero.Value .DataBodyRange(RowIndex:=n, columnindex:=8).Value = Sistema.txt_bairro.Value .DataBodyRange(RowIndex:=n, columnindex:=9).Value = Sistema.txt_local.Value Range("ID").Value = id + 1 With Sistema .txt_nome.Text = "" .cbb_sexo.Text = "" .txt_telefone.Text = "" .txt_cep.Text = "" .txt_endereco.Text = "" .txt_numero.Text = "" .txt_bairro.Text = "" .txt_local.Text = "" End With Call Atualizar_listclientes MsgBox "Cadastrado com sucesso!", vbInformation, "Informação" End With End Sub  
*Caso o erro persista, tente deletar toda a tabela "Clientes" e inserir novamente.

@diego_janjao para criar uma pasta neste formato [ 01.Janeiro ], de acordo com a coluna "E", substitue
 
Esta linha:
 
save = ThisWorkbook.Path & "\" & Format(Cells(Target.Row, 4).Value, "000000") & " - " & Cells(Target.Row, 8).Value & " - " & Cells(Target.Row, 11).Value  
 
por esta:
 
save = ThisWorkbook.Path & "\" & VBA.Month(Cells(Target.Row, 5).Value) & "." & VBA.StrConv(VBA.MonthName(VBA.Month(Cells(Target.Row, 5).Value)), 3)  

@EVA MONTEIRO bom dia 
Criei um menu com um botão para acionar a macro:
 
1 - Click na Tab superior: [suplementos] ....

 
2 - E do lado esquerdo, superior [Menu] e no botão [Macro Salvar ...]

 
3 - Abrirá uma janela perguntando em qual pasta deseja salvar os documento(s) pdf(s) que serão criados.
 
Veja se é isso que deseja.
 
Files.zip

@marcospires1 bom considerando que a data esteja na celula A1 segue exemplo: 
 
With ActiveSheet LOCALNOME = ThisWorkbook.Path & "\Pedido" & "_" & VBA.Format(.[A1], "dd-mm-yyyy") & .[K2] & .[G5] & ".pdf" End With  
 
Pode-se tambem alterar a formatação da data colocando ao contrario, ou seja ano-mes-dia 
 
LOCALNOME = ThisWorkbook.Path & "\Pedido" & "_" & VBA.Format(.[A1], "yyyy-mm-dd") & .[K2] & .[G5] & ".pdf"  
 

@Luciana Goes veja a sugestão: 
 
Private Sub ListBox1_Click() Dim rng As Range Dim r As Range Dim shSg As Worksheet Set shSg = ThisWorkbook.Worksheets("SUGESTÃO PARA CONDICIONAL") Set rng = shSg.Range("A1").Resize(1, shSg.Cells(1, Columns.Count).End(xlToLeft).Column).Find(Me.ListBox1.Text, _ LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Set r = shSg.Cells(2, rng.Column).Resize(shSg.Cells(Rows.Count, rng.Column).End(xlUp).Row, _ rng.Column) With ListBox2 .Clear .RowSource = "" .List = r.Value End With End If End Sub  
O codigo atende de forma dinamica, ou seja se acrescentar mais dados em colunas e/ou linhas não precisa ser ajustado.
 

@deejaywesley substitua a linha abaixo no seu código
 
wbkDestino.SaveAs ThisWorkbook.Path & "\" & "Grupo " & intQtdGruposEnviados + 1, FileFormat:=xlCSV, local:=True  

Veja se é isso que precisa: 
 
=SE(C5=D5;"ok";D5)  

@Angela Leticia experimente inserir o EnableEvents = False no inicio do codigo e no final EnableEvents = True
 
 
Private Sub Worksheet_Change(ByVal Target As Range) Dim cvalor As Currency, svalor As Variant, iqtd As Integer, iqtdluz As Integer Dim cvalorAux As Currency, ctotalArea As Currency On Error GoTo trata_erro: If Target.Address = Range("C4").Address Or Target.Address = Range("C5").Address Or _ Target.Address = Range("C6").Address Or Target.Address = Range("C7").Address Or _ Target.Address = Range("C8").Address Or Target.Address = Range("C9").Address Or _ Target.Address = Range("C10").Address Or Target.Address = Range("C11").Address Or _ Target.Address = Range("C12").Address Or Target.Address = Range("C13").Address Then Excel.Application.EnableEvents = False 'atribui os valores das célula para estas variáveis cvalor = CCur(Range("C4")) svalor = CStr(Range("C4")) cvalorAux = Right(svalor, 2) cvalor = Right(svalor, 2) ctotalArea = CCur(Range("C4")) 'inícia o loop que irá incrementar o valor de de 40 em 40 em cada interação iqtdluz = 0 iqtd = 0 If (ctotalArea / 6) <= 6 Then Exit Sub iqtdluz = 100 iqtd = 0 End If Do While cvalorAux <= cvalor cvalorAux = (cvalorAux + 40) iqtdluz = iqtdluz + 60 iqtd = iqtd + 1 Loop Range("E4") = iqtd Range("F4") = iqtdluz Excel.Application.EnableEvents = True Exit Sub 'trecho para tratamento de erros trata_erro: If Err.Number = 13 Then Err.Clear MsgBox "Houve um erro. ", "Verifique o valor digitado!!" Excel.Application.EnableEvents = True Exit Sub End If End If End Sub  

@josequali nesta consulta de data, nenhum dos campos pode estar vazio, caso contrário vai gerar erros.

O comando Limpar filtros, deixa um dos critérios de data sem dados (vide img acima)
 
Neste caso é necessário o tratamento de erro, para não executar o comando SQL, caso algum campo envolvido não esteja vazio.
 
E tambem, atualizei o formato da data, para o americano, na clausula sql para não gerar inconsistências. 
 
rs.Open "SELECT * FROM TabNaoConformidades WHERE DATACAD BETWEEN #" & _ VBA.Format(filtro6.Text, "mm/dd/yyyy") & "# AND #" & _ VBA.Format(filtro4.Text, "mm/dd/yyyy") & _ "# AND EMPRESA='" & Me.filtro2.Text & "'", db, 3, 3  

@Miguelriedel segue sugestão.
 
Formula matricial [ cltr+shift+enter ]
 
 
*Outra opção s/ matricial, com a função agrupar
Exemplo_Procv_Mult_Ocorren_Agrupar.xlsx
 
 
Exemplo_Procv_Mult_Ocorren.xlsx

@Scofieldgyn  Segue opção: 
 
No modulo de EstaPasta_de_trabalho 
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim Ev As String Ev = "Salvou" Call Test_LOG(Ev) End Sub  
Pode criar uma aba nomeando-a como Log
...em um modulo padrão:
 
Sub Test_LOG(Ev As String) Dim linha! With ThisWorkbook.Sheets("Log") If Cells(Rows.Count, 1).End(xlUp).Row <= 1 Then .Range("A1").Value = "Evento" .Range("B1").Value = "Usuario" .Range("C1").Value = "Dominio" .Range("D1").Value = "Computador" .Range("E1").Value = "Data e Hora" linha = 2 End If linha = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row .Range("A" & linha).Value = Ev .Range("B" & linha).Value = VBA.Environ("UserName") .Range("C" & linha).Value = VBA.Environ("USERDOMAIN") .Range("D" & linha).Value = VBA.Environ("COMPUTERNAME") .Range("E" & linha).Value = VBA.Now() .Columns.AutoFit End With End Sub  

@josequali bom dia!
Experimente a função max 
 
' Se o campo Origem for numerico (valor) rs.Open "SELECT MAX(campo_Numerico) FROM TabNaoConformidades WHERE [campo_Numerico]>0", Db, 3, 3 ' Se o campo Origem for do tipo string rs.Open "SELECT MAX(campo_String) FROM TabNaoConformidades WHERE [campo_String]>'0'", Db, 3, 3 If Not rs.EOF Then Me.txtId1.Text = rs(0).Value + 1 End If  

@Murilo_Correa experimente agora com as alterações
 
Fiz uns remendos no que já havia feito, e agora ficou parecendo um frankenstein, mas deve fucinionar:
 
* Se puder post o print com o resultado da importação, para efito de ilustração aqui no topico: 
 
Sub Login_Suframa_Por_Celulas() ' Por bbasole882gmail.com Dim driver As New ChromeDriver Dim r As Range Dim Row As Object Dim body As Object Dim cell As Object Dim x: x = 1 Dim oTable As Object Dim RowTh As Object Dim cellTh As Object Dim sThtd As String: sThtd = "th" On Error GoTo trER: Excel.Application.ScreenUpdating = False With driver .Get "https://simnac.suframa.gov.br" .Wait (1000) .FindElementByName("usuario").SendKeys ("USUARIO") ' * ALTERAR .FindElementByName("senha").SendKeys ("SENHA") ' * ALTERAR .Wait (1000) .FindElementByXPath("/html/body/app-root/div/div/div/section/section/footer/button", 5).Click .Wait (5000) ' adiciona nova aba: With ThisWorkbook .Sheets.Add(Before:=Sheets(1)).Name = "Quadro Resumo_1" End With .Wait (1000) For Each oTable In .FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table") For Each RowTh In oTable.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/thead/tr") For Each cellTh In RowTh.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/thead/tr[" & x & "]/" & sThtd & "") y = y + 1 If VBA.InStr(1, cellTh.Text, "TOTAL") > 0 Then y = 9: Cells(x, y) = VBA.Replace(cellTh.Text, VBA.Chr(10), " ") Else Cells(x, y) = VBA.Replace(cellTh.Text, VBA.Chr(10), " ") End If Next ' efeito zebrado no intevalo de dados: If x Mod 2 <> 0 Then Set r = Range(Cells(x, 1), Cells(x, 9)): r.Interior.ThemeColor = xlThemeColorDark1: r.Interior.TintAndShade = -0.25 '15 End If x = x + 1 y = 0 sThtd = "td" Next RowTh Next oTable x = 1: y = 0 For Each body In .FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table") For Each Row In body.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/tbody/tr") For Each cell In Row.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/tbody/tr[" & x & "]/td") y = y + 1 If VBA.InStr(1, cell.Text, "TOTAL DE PENDÊNCIAS POR DIAS PARA EXPIRAÇÃO DO PRAZO") > 0 Then y = 4: Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " "): Cells(x + 2, y).Font.Bold = True ' negrito Else If VBA.IsNumeric(cell.Text) And y = 1 Then Cells(x + 2, y) = "" ElseIf VBA.InStr(1, cell.Text, "Vistoria ") > 0 And y = 1 Then y = 2 Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " ") Else Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " ") End If End If Next cell ' efeito zebrado no intevalo de dados: If x Mod 2 <> 0 Then Set r = Range(Cells(x + 2, 1), Cells(x + 2, 9)): r.Interior.ThemeColor = xlThemeColorDark1: r.Interior.TintAndShade = -0.15 End If x = x + 1 y = 0 Next Row Next body Range("A:A").EntireColumn.ColumnWidth = 3.2: Range("B:D").EntireColumn.ColumnWidth = 45: Range("E:i").EntireColumn.ColumnWidth = 8.2 Range("1:1").EntireRow.RowHeight = 26.75: Range(Cells(1, 1), Cells(1, 9)).Font.Size = 12: Range(Cells(1, 1), Cells(1, 9)).Font.Bold = True ' negrito .Quit End With trER: Excel.Application.ScreenUpdating = True End Sub  

@Murilo_Correa experimente agora com as alterações
 
Fiz uns remendos no que já havia feito, e agora ficou parecendo um frankenstein, mas deve fucinionar:
 
* Se puder post o print com o resultado da importação, para efito de ilustração aqui no topico: 
 
Sub Login_Suframa_Por_Celulas() ' Por bbasole882gmail.com Dim driver As New ChromeDriver Dim r As Range Dim Row As Object Dim body As Object Dim cell As Object Dim x: x = 1 Dim oTable As Object Dim RowTh As Object Dim cellTh As Object Dim sThtd As String: sThtd = "th" On Error GoTo trER: Excel.Application.ScreenUpdating = False With driver .Get "https://simnac.suframa.gov.br" .Wait (1000) .FindElementByName("usuario").SendKeys ("USUARIO") ' * ALTERAR .FindElementByName("senha").SendKeys ("SENHA") ' * ALTERAR .Wait (1000) .FindElementByXPath("/html/body/app-root/div/div/div/section/section/footer/button", 5).Click .Wait (5000) ' adiciona nova aba: With ThisWorkbook .Sheets.Add(Before:=Sheets(1)).Name = "Quadro Resumo_1" End With .Wait (1000) For Each oTable In .FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table") For Each RowTh In oTable.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/thead/tr") For Each cellTh In RowTh.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/thead/tr[" & x & "]/" & sThtd & "") y = y + 1 If VBA.InStr(1, cellTh.Text, "TOTAL") > 0 Then y = 9: Cells(x, y) = VBA.Replace(cellTh.Text, VBA.Chr(10), " ") Else Cells(x, y) = VBA.Replace(cellTh.Text, VBA.Chr(10), " ") End If Next ' efeito zebrado no intevalo de dados: If x Mod 2 <> 0 Then Set r = Range(Cells(x, 1), Cells(x, 9)): r.Interior.ThemeColor = xlThemeColorDark1: r.Interior.TintAndShade = -0.25 '15 End If x = x + 1 y = 0 sThtd = "td" Next RowTh Next oTable x = 1: y = 0 For Each body In .FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table") For Each Row In body.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/tbody/tr") For Each cell In Row.FindElementsByXPath("//*[@id='content']/section/section/section/section/app-consultar-quadro-pin/div/div/div/section/form/div/table/tbody/tr[" & x & "]/td") y = y + 1 If VBA.InStr(1, cell.Text, "TOTAL DE PENDÊNCIAS POR DIAS PARA EXPIRAÇÃO DO PRAZO") > 0 Then y = 4: Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " "): Cells(x + 2, y).Font.Bold = True ' negrito Else If VBA.IsNumeric(cell.Text) And y = 1 Then Cells(x + 2, y) = "" ElseIf VBA.InStr(1, cell.Text, "Vistoria ") > 0 And y = 1 Then y = 2 Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " ") Else Cells(x + 2, y) = VBA.Replace(cell.Text, VBA.Chr(10), " ") End If End If Next cell ' efeito zebrado no intevalo de dados: If x Mod 2 <> 0 Then Set r = Range(Cells(x + 2, 1), Cells(x + 2, 9)): r.Interior.ThemeColor = xlThemeColorDark1: r.Interior.TintAndShade = -0.15 End If x = x + 1 y = 0 Next Row Next body Range("A:A").EntireColumn.ColumnWidth = 3.2: Range("B:D").EntireColumn.ColumnWidth = 45: Range("E:i").EntireColumn.ColumnWidth = 8.2 Range("1:1").EntireRow.RowHeight = 26.75: Range(Cells(1, 1), Cells(1, 9)).Font.Size = 12: Range(Cells(1, 1), Cells(1, 9)).Font.Bold = True ' negrito .Quit End With trER: Excel.Application.ScreenUpdating = True End Sub  

@Miguelriedel atraves de fórmula, talvez algum colega pode lhe ajudar.
 
Mas se preferir através desta udf (User Defined Function) , função customizada para atender sua demanda. 
Tive que fazer pequenas alterações no lay-out da planilha2, para atender o formato de BD.
 
 
Segue exemplo em anexo:
Exemplo controle requisição_v1.zip

@Scofieldgyn Eu já atualizei o código dê uma olhada, por favor

@Scofieldgyn Eu já atualizei o código dê uma olhada, por favor

@Scofieldgyn Eu já atualizei o código dê uma olhada, por favor

Esperimente acrescentar no codigo uma "espera" para a pagina carregar completamente:
Após a linha Loop...
 
Application.Wait (Now + TimeValue("00:00:05")) ' 5 segundos   

Experimente desta forma:
 
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject") 
Set f = fs.GetFile(caminho & sua_pasta de trabalho)
resultado = f.DateLastModified