Listedeki verileri kapalı dosyalarda ara bul ve köprü (hyperlink) ata.

[Bora K]

Merhabalar.

Listedeki isimleri (kitab adı) belirtilen dosya yolunda arayacak.
Aynı isimli kitabı bulur ise yan tarafındaki butona köprü atayacak.

Değerli uzmanlarımızın yardımlarını bekliyorum.
Saygılarımla.

 

[Bora K]

Mehrabalar
Aşağıdaki kod Necdet Hocaya
ait. Kodun mantığı benim dosyaya uygun lakin ben
kendime göre revize edemedim.

Sub Kopru_Ekle()
 
    Dim i       As Long
    Dim j       As Long
    Dim Yol     As String
 
    Yol = "C:\"
 
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
 
        If Dir(Yol & Range("A" & i) & ".pdf") > "" Then
            j = j + 1
            ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & i), Address:= _
            Yol & Range("A" & i) & ".pdf"
        End If
    Next i
 
    MsgBox j & " Adet Dosyaya Köprü Ekledim..."
 
End Sub

 

[muygun]

Merhaba;
Ekteki uygulama işinizi görür mü?
İnceleyin.
İyi çalışmalar.

Not: Kodlar alıntıdır.

 

[Bora K]

Merhabalar Üstad.

Alakanız için teşekkür ederim öncelikle.
İlgili dosya yolunda duruma göre yüzlerce bincerle
dosya olabiliyor. Bu durumda linklerin içinde kayboluruz
gibime geliyor. Dahası örnek dosyadaki formatta olması lazım.
(Buton olmasada olur) Orada ki satır boşlukları ve 2 kitap arasındaki
boşluklarda başka işlemler yapılacak.

Şayet bilginiz dahilinde ise ilgilenebilirseniz çok sevinirim.
Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Sub Kopru_Ekle()
    Dim Klasor As Object, Dosya As String, X As Long
    
    Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Klasör seçiniz !", 1)
    If Klasor Is Nothing Then Exit Sub
    
    Range("A:A").Clear
    Range("A1") = "Dosya Bağlantıları"
     
    Dosya = Dir(Klasor.Self.Path & "\*.*")
    
    While Dosya <> ""
        DoEvents
        X = Cells(Rows.Count, 1).End(3).Row + 1
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(X, 1), _
        Address:=Klasor.Self.Path & "\" & Dosya, TextToDisplay:=Dosya
        Dosya = Dir
    Wend
    
    Set Klasor = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Bora K]

Korhan Hocam
Alakanız için çok teşekkür ederim.
Öncelikle şunu belirteyim ki, dosya yolunu bu şekilde seçmek çok hoş
olmuş. Bu kısım ala.

Mümkünatı var ise şayet kod için bir miktar daha esneklik istemekteyim.

Şu ilaveleri yapabilirmiyiz acaba?
*** .xls uzantıları gelmeyecek
(Bora.xls şeklinde değilde Bora şeklide gelsin)

*** A sütununda listelenmesinde 3. satırdan başlamak kaydı ile
C H L Q sütunlarında eşit şekilde listelensin.
(Mümkünse eğer bu kısım opsiyonel olsun kod içinde
sütun ilave edeyim yada sütun eksiltebileyim)

 

[halit3]

Merhabalar.

Listedeki isimleri (kitab adı) belirtilen dosya yolunda arayacak.
Aynı isimli kitabı bulur ise yan tarafındaki butona köprü atayacak.

Değerli uzmanlarımızın yardımlarını bekliyorum.
Saygılarımla.

Alternatif kod:

Sub köprüata()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column + 3).Value
Dim fs As Object, fLk As Object
Set fLk = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fLk.GetFolder(Kaynak).Files
dosya2 = fLk.GetBaseName(Dosya)

If dosya2 = yer Then
ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=Dosya
End If
Next

End If

Next Picture
Set Klasor = Nothing
Range("a1").Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub


Sub köprüsil()

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
On Error Resume Next
ActiveSheet.Shapes(Picture.Name).Select
Selection.ShapeRange.Item(1).Hyperlink.Delete

End If
Next Picture
Range("a1").Select
MsgBox "işlem tamam"


End Sub

 

[Bora K]

Merhabalar
Halit Hocam her zamanki gibi
yine harika bir kod olmuş.
Çok çok teşekkür ediyorum.

Yukarıdaki kodun kalması şartı ile. Herşey tıpkısının
aynısı olacak sadece koda dosya yolunu manuel yazacağız
(Dosya yolu kodun içinde olacak şekilde)
bu alternatifi de bize/bizlere sunarsanız müteşekkir olurum.

Saygılarımla.

 

[halit3]

Merhabalar
Halit Hocam her zamanki gibi
yine harika bir kod olmuş.
Çok çok teşekkür ediyorum.

Yukarıdaki kodun kalması şartı ile. Herşey tıpkısının
aynısı olacak sadece koda dosya yolunu manuel yazacağız
(Dosya yolu kodun içinde olacak şekilde)
bu alternatifi de bize/bizlere sunarsanız müteşekkir olurum.

Saygılarımla.

kod:

Sub köprüata()

yol = ThisWorkbook.Path & "\Yeni"
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column + 3).Value
Dim fs As Object, fLk As Object
Set fLk = CreateObject("Scripting.FileSystemObject")
For Each Dosya In fLk.GetFolder(yol).Files
dosya2 = fLk.GetBaseName(Dosya)
If dosya2 = yer Then
ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=Dosya
End If
Next
End If
Next Picture
Set Klasor = Nothing
Range("a1").Select
MsgBox "işlem tamam"

End Sub

 

[Bora K]

Çok saolunuz.
Herşey gönlünüzce olsun inşallah.