Hücreye dosya sürükleyip link oluşturma

[D.Ozsahin]

Selam arkadaşlar,

Örnek olarak : Aşağıdaki gibi 3000 satır doküman numarası var. Klasörler içerisinde bu doküman numaralarının karşılığı pdf ya da dwg dosyaları mevcut. Benim bunların hepsine link vermem gerekiyor fakat sağ tıklayıp köprü oluştur, ilgili klasörü seç diye gittiğim zaman tahmin edeceğiniz gibi çok zaman alıyor. Mevcut dosyayı excel içerisine sürükleyip bir link oluşturmak mümkün mü ? Ya da bunu yapabileceğim bir macro var mı elinizde ?

 

[muratboz06]

HyperLinkCreate makrosunu çalıştırırsanız A1 hücresinden A100 hücresinde yazan değerleri C:\Murat\ klasörü ve alt klasörlerinde arar, bulursa hypherlink oluşturur.
For i = 1 To 100 ve Range("A" & i).Select satırlarını kendinize göre revize ediniz.

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String

Sub HyperLinkCreate()
    Dim i As Long
    For i = 1 To 100        'A1 hücresinden A100 hücresine kadar işlem yapar. Burayı kendinize göre revize ediniz.
        Range("A" & i).Select        'A1 hücresinden A100 hücresine kadar işlem yapar. Burayı kendinize göre revize ediniz.
        If IsEmpty(ActiveCell) = FALSE Then
            Call FindFile
        End If
    Next i
    MsgBox "İşlem tamamlandı"
    Range("A1").Select
End Sub

Sub FindFile()
    HostFolder = "C:\AdamAy\"
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
    
End Sub
Sub DoFolder(Folder)
    
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If InStr(File.Name, ActiveCell.Value) > 0 Then
            ActiveSheet.Hyperlinks.Add ActiveCell, Folder.Path & "\" & File.Name
            
            Exit Sub
        End If
    Next
    
End Sub

 

[D.Ozsahin]

HyperLinkCreate makrosunu çalıştırırsanız A1 hücresinden A100 hücresinde yazan değerleri C:\Murat\ klasörü ve alt klasörlerinde arar, bulursa hypherlink oluşturur.
For i = 1 To 100 ve Range("A" & i).Select satırlarını kendinize göre revize ediniz.

Option Explicit
Dim FileSystem As Object
Dim HostFolder As String

Sub HyperLinkCreate()
    Dim i As Long
    For i = 1 To 100        'A1 hücresinden A100 hücresine kadar işlem yapar. Burayı kendinize göre revize ediniz.
        Range("A" & i).Select        'A1 hücresinden A100 hücresine kadar işlem yapar. Burayı kendinize göre revize ediniz.
        If IsEmpty(ActiveCell) = FALSE Then
            Call FindFile
        End If
    Next i
    MsgBox "İşlem tamamlandı"
    Range("A1").Select
End Sub

Sub FindFile()
    HostFolder = "C:\AdamAy\"
   
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
   
End Sub
Sub DoFolder(Folder)
   
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        If InStr(File.Name, ActiveCell.Value) > 0 Then
            ActiveSheet.Hyperlinks.Add ActiveCell, Folder.Path & "\" & File.Name
           
            Exit Sub
        End If
    Next
   
End Sub

Çok teşekkür ediyorum çok işime yaradı sağolun.