1) Como salvar pdfs provenientes de um hyperlink 2) em uma pasta direcionada 3) e baixar esses arquivos renomeados de acordo com uma coluna da planilha 4) Usando VBA

[GSS]

Olá, pessoal!

 

Como tenho pouca experiência em VBA, estou com dificuldade em desenvolver um código para atender minha necessidade. Garimpando na internet encontrei alguns códigos prontos que ajudaram em partes, mas não toda minha necessidade.

 

Tenho uma planilha do excel com duas colunas:

coluna A: exame da Semana - novembro - 07-11-2022.pdf

coluna B: https://drive.google.com/uc?export=download&id=1 

 

Gostaria de salvar esse pdf do hiperlink com o nome de acordo com a coluna A no endereço C:\teste\

 

Encontrei este código, mas ele vai direto para meus downloads, ignorando as etapas de: alteração do nome do arquivo e também ignorando pasta que eu quero salvá-lo:

 

Sub OpenHyperLinks()
'Update 20141124
    Dim xHyperlink As Hyperlink
    Dim WorkRng As Range
    On Error Resume Next
    xTitleId = "KutoolsforExcel"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    For Each xHyperlink In WorkRng.Hyperlinks
        xHyperlink.Follow
    Next
End Sub

 

_________________________________________________________________________________________________________________________

Esse outro código que encontrei, o resultado foi o que eu queria, porém os arquivos abrem como corrompidos:

 

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Sub FazDownloadArquivos()
'macro que faz o download de arquivos a partir da URL da PLANILHA DADOS

Dim NomeDiretorio As String
Dim SiteArquivo, NomeSalvar As String
Dim Resultado, i As Integer

NomeDiretorio = "\\Documents\teste MACRO exame\"
If Dir(NomeDiretorio, vbDirectory) = "" Then
MsgBox "Deu ruim, o diretório não existe!"
Else
For i = 2 To 6
SiteArquivo = Worksheets("Recebimento_Exames").Cells(i, 2)
NomeSalvar = NomeDiretorio & Worksheets("Recebimento_Exames").Cells(i, 1).Value & ".pdf"
Resultado = URLDownloadToFile(0, SiteArquivo, NomeSalvar, 0, 0)
If Resultado <> 0 Then
MsgBox "Não consegui achar o arquivo  " & SiteArquivo
End If
Next i
End If
End Sub

 

 

ALGUÉM DA COMUNIDADE PODE ME AJUDAR?

 

Obrigada!!!

 

 

Editado Novembro 8, 2022 por GSS