Boa Tarde, Gênios!!!
Os amigos poderiam me ajudar neste obstáculo?
Tenho uma macro que qdo clico no botão “Link”, a macro abre uma opção para o usuário selecionar o intervalo e a partir disso me mostra o caminho em que o PDF se encontra e faz o Hiperlink.
Ocorre que a macro está criando o primeiro link da planilha para todos as Notas do intervalo, qdo o ideal seria a Macro criar o Hiperlink para todas as numerações com os seus respectivos PDF do Diretório.
Deixei o Código na planilha de amostra pra ficar mais claro o entendimento.
Consegue me ajudar?
Sub CriarHiperlinks()
Dim ws As Worksheet
Dim rng As Range
Dim folderPath As String
Dim fileNumber As String
Dim fileName As String
Dim filePath As String
Dim foundFiles As Boolean
Dim i As Long, j As Long
Dim files As Variant
' Referência à planilha ativa
Set ws = ActiveSheet
' Solicita ao usuário para selecionar o intervalo da coluna B
On Error Resume Next
Set rng = Application.InputBox("Selecione o intervalo da coluna B", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
' Pede ao usuário o diretório onde os arquivos PDF estão salvos
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecione o diretório onde estão os arquivos PDF"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
folderPath = .SelectedItems(1)
End With
' Obter todos os arquivos PDF no diretório
files = GetAllPDFFiles(folderPath)
' Loop através das células selecionadas na coluna B
For Each cell In rng
' Verifica se o valor na célula é um número
If IsNumeric(cell.Value) Then
' Obtém o número da nota fiscal da célula
fileNumber = CStr(cell.Value)
' Procurar arquivo correspondente
foundFiles = False
For j = LBound(files) To UBound(files)
' Verifica se o nome do arquivo contém o número da nota fiscal
If InStr(files(j), fileNumber) > 0 Then
' Cria o caminho completo do arquivo PDF
filePath = folderPath & "\" & files(j)
' Cria o hiperlink na célula
cell.Hyperlinks.Add Anchor:=cell, Address:=filePath, TextToDisplay:=fileNumber
' Encontrou pelo menos um arquivo correspondente
foundFiles = True
End If
Next j
' Se não encontrou nenhum arquivo correspondente, exibe uma mensagem de aviso
If Not foundFiles Then
MsgBox "Nenhum arquivo correspondente à nota fiscal " & fileNumber & " foi encontrado no diretório selecionado.", vbExclamation
End If
End If
Next cell
MsgBox "Hiperlinks criados com sucesso.", vbInformation
End Sub
Function GetAllPDFFiles(folderPath As String) As Variant
Dim fso As Object
Dim objFolder As Object
Dim objFile As Object
Dim pdfFiles As Variant
Dim i As Long
' Inicializa o objeto FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Verifica se o diretório existe
If fso.FolderExists(folderPath) Then
' Obtém o objeto do diretório
Set objFolder = fso.GetFolder(folderPath)
' Inicializa o array para armazenar os nomes dos arquivos PDF
ReDim pdfFiles(0 To objFolder.files.Count - 1)
' Loop através dos arquivos no diretório
i = 0
For Each objFile In objFolder.files
' Verifica se o arquivo é um PDF
If LCase(fso.GetExtensionName(objFile.Path)) = "pdf" Then
' Adiciona o nome do arquivo ao array
pdfFiles(i) = objFile.Name
i = i + 1
End If
Next objFile
' Redimensiona o array para remover os elementos não utilizados
ReDim Preserve pdfFiles(0 To i - 1)
' Retorna o array com os nomes dos arquivos PDF
GetAllPDFFiles = pdfFiles
Else
' Retorna um array vazio se o diretório não existe
GetAllPDFFiles = Array()
End If
' Limpa a memória dos objetos
Set fso = Nothing
Set objFolder = Nothing
Set objFile = Nothing
End Function