Excelde satırdaki hücre değerine link ekleme

[spasmex97]

Merhaba arkadaşlar, yaklaşık 1000 satırlı bir excel dosyam bulunmakta, bunlar parça kodlarını içeriyor, pdf lerine ulaşmak için bağlantı ekle sekmesi kullanıyorum fakat bazı parçalar 8-10 alt parçadan oluşuyor ve hepsi için eklemek gerçekten yorucu, sabahtan beri uğraşıyorum 150 tane anca yapabildim, 6-7 bin satırlı excel dosyaları da var böyle, vba da kod yazarak otomatik olarak o parça koduyla aynı isme sahip pdf leri içeren dosyaya link bağlamak istiyorum, tek tek yapmak yerine tek hamlede hepsine link nasıl link bağlayabilirim?

 

[ccuneyt13]

Merhaba,
Elimde aşağıdaki gibi bir kod var. Özetle şunu yapıyor.
Masaüstünde FATURALAR isimli bir klasör var ve içerisinde de pdf uzantılı faturalar var.
A2 den başlayarak FATURALAR klasöründeki pdf lerin dosya isimlerini alt alta yazıyorum.
Makroyu çalıştırdığınızda B2'den itibaren linkler otomatik gelir.

Mesela klasörün içinde OCAKFATURA.pdf isimli dosya var.
A2'ye OCAKFATURA yazarsanız B2'ye link olarak ekler.

Sub kopru_yap()
Dim S1, Son, i
Set S1 = ThisWorkbook.Sheets("Sayfa1")
'Çalıştığınız sayfa ismi ne ise ona göre Sayfa1 yazan yeri değiştirin.

Son = Sheets("Sayfa1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Son
Range("B" & i).Select
'burdaki B köprü oluşturulacak hücre listenizde hangi hücreyi isterseniz değiştirin.

Selection.Hyperlinks.Add Anchor:=Selection, Address:="C:\Users\kullanıcı.adı\Desktop\FATURALAR\" & Cells(i, "A") & ".pdf", _
TextToDisplay:="SURET" 'Linkin adı
'dosya isimleri alt alt A sutununda olduğu varsayılmıştır. Siz dosya isimleri hangi sütunda ise ona göre değiştirin.
Next i
End Sub

C:\Users\kullanıcı.adı\Desktop\FATURALAR\ bu kısmı klasörünüzün olduğu dosya yolu ile ne ise ona göre değiştirin. Sondaki kırmısı işaretledeğim slash \ mutlaka olmalı.

Umarım işinize yarar.

 

[spasmex97]

object define error alıyorum, benim linklemek istediklerim pdf değil normal dosya, ama uzantı kodunu bulamıyorum hiçbir yerde, acaba .dir falan mı?

 

[ccuneyt13]

Klasörünüz açıkken windowsun üstteki menülerinden Klasör özelliklerinden dosya uzantlarını göster deyin.
Yada bir dosyanın üstüne sağ klik yapın özellikler dedikten sonra genel sekmesinde Dosya Türü ne ise orada da yazar uzantsı.

 

[spasmex97]

Klasörünüz açıkken windowsun üstteki menülerinden Klasör özelliklerinden dosya uzantlarını göster deyin.
Yada bir dosyanın üstüne sağ klik yapın özellikler dedikten sonra genel sekmesinde Dosya Türü ne ise orada da yazar uzantsı.

dosya uzantısı kısmında bir şey yazmıyor, "folder" için bir uzantı yok sanırım

 

[ccuneyt13]

Forumda aşağıdaki kodları buldum. Yeni bir excel de çalıştırın dosyalarınızın olduğu klasörü seçin içinde olan dosyaların adını ve uzantısını listeliyor.
Ordan bakıp bilgi edinmeye çalışalım.

Uzantıları olmadan isim değiştirme yapmaz. Ayrıca dosya konumunu da bir yere not etmesi gerekli.
Eğer C1 e dosya konumunu ve alt satırlara da A sutununa yazdığı dosyaların uzantısını yazsın.
Aşağıdaki şekilde iki buton ile işleminizi yapabilirsiniz.

Sub Dosya_Listeleme()
    Dim I As Long
    Dim xFileName As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    On Error Resume Next
    Cells(1, 3).ClearContents
    Columns("A").ClearContents
    Columns("C").ClearContents
    Range("A1:C65536").Interior.Color = xlNone
  I = 1
    Cells(I, 1).Value = "Dosya Adı"
    With Cells(I, 1).Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 10
    End With
    Cells(I, 1).EntireColumn.AutoFit
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
 
    If xFileDlg.Show = -1 Then
        xFileDlgItem = xFileDlg.SelectedItems.Item(1)
        If Cells(1, 3) = Empty Then Cells(1, 3) = xFileDlgItem
        xFileName = Dir(xFileDlgItem & "\")
        Do While xFileName <> ""
                I = I + 1
                DosyaAdi = Split(xFileName, ".")
                Cells(I, 1).Value = Mid(xFileName, 1, Len(xFileName) - Len(DosyaAdi(UBound(DosyaAdi))) - 1)
                Cells(I, 3).Value = DosyaAdi(UBound(DosyaAdi))
                xFileName = Dir
        Loop
    End If
    Columns("A").AutoFit
    Application.ScreenUpdating = True
End Sub