Toplu Hyperlink Kurma - Makro

[ridvanucok]

Merhaba,

Ekte yer alan örnek datada sarı ile belirtilen hücreler manuel olarak linkleme yaptığım işlemlerdir.

Yapmak istediğim işlem ise, A hücresinin son aktif hücresi ile C hücresinin son aktif hücresi sırası kadar ( Örn: A9'dan, A13'e kadar) otomatik olarak bugünün tarihini yazdırmak ve "C:/RIDVAN" klasöründen F sütunu ( AD SOYAD)'ndaki hücreler ile .tif ve .pdf dosyalarının birebir eşleşmesi durumunda toplu olarak linkleme yapacak. Bu işlemi makro toplu olarak nasıl yapabilirim? Değerli yardımlarınızı rica ederim.

 

[Necdet]

Merhaba,

Umarım doğru anlamışımdır. Aşağıdaki kodları deneyiniz. Denemedin önce dosyanızın yedeğini alınız.

Eğer ilgili kişide birden fazla resim vs varsa ilkini alır.

Sub LinkEkle()

    Dim i   As Long
    Dim Yol As String
    Dim Dsy As String
    Dim Kol As Integer
    Dim c   As Range
    
    Application.ScreenUpdating = False
    
    Kol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    Yol = "C:\RIDVAN" & Application.PathSeparator
    
    i = 1
    Dsy = Dir(Yol)
    While Dsy <> ""
        Cells(i, Kol) = Dsy
        Dsy = Dir
        i = i + 1
    Wend
    
    i = Cells(Rows.Count, "C").End(3).Row

    With Range("A2:A" & i)
        .Clear
        .Hyperlinks.Delete
        .FormulaR1C1 = Date
    End With
    
    For i = 2 To Cells(Rows.Count, "C").End(3).Row
    
        Set c = Columns(Kol).Find(Cells(i, "F"), LookIn:=xlValues)
        If Not c Is Nothing Then Range("A" & i).Hyperlinks.Add Anchor:=Range("A" & i), Address:=Yol & Cells(c.Row, Kol)
    
    Next i
    
    Columns(Kol).Delete
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlanmıştır....."
    
End Sub

 

[ridvanucok]

Necdet Üstadım merhaba,

Linkleme konusunda tam da istediğim şekilde olmuş. Elinize sağlık. Fakat A hücresinde sadece boş olan hücrelere günümüz tarihi atmasını planladım. A hücresinde tüm tarihleri günümüz tarihi ile değiştirmektedir. Değerli yardımlarınızı rica ederim.

Teşekkür ederim.

 

[Necdet]

Merhaba,

Sadece boş olan hücrelere tarih ve link eklenecek, doğru mu?
Yoksa boş olan hücrelere tarih eklenecek ve tüm hücrelere de link mi verilecek?

 

[ridvanucok]

Üstadım merhaba,

Sadece boş olan hücreleri tarih eklenecek ve eklenen hücrelere linkleme yapılacak.

Değerli yardımlarını rica ederim.

 

[ridvanucok]

Merhaba,

Yardım talebim devam etmektedir. Yardımlarınızı rica ederim.

 

[Necdet]

Merhaba,

Kodları deneyiniz. Benim deneme şansım olmadı.

Sub LinkEkle()

    Dim i   As Long
    Dim Yol As String
    Dim Dsy As String
    Dim Kol As Integer
    Dim c   As Range
    Dim Rng As Range
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    Kol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1
    Yol = "C:\RIDVAN" & Application.PathSeparator
    
    i = 1
    Dsy = Dir(Yol)
    While Dsy <> ""
        Cells(i, Kol) = Dsy
        Dsy = Dir
        i = i + 1
    Wend
    
    i = Cells(Rows.Count, "C").End(3).Row

    For Each Rng In Range("A1:A" & i).SpecialCells(xlCellTypeBlanks)
        Rng.Value = Date
        Set c = Columns(Kol).Find(Rng.Offset(0, 5), LookIn:=xlValues)
        If Not c Is Nothing Then Rng.Hyperlinks.Add Anchor:=Rng, Address:=Yol & Cells(c.Row, Kol)        
    Next Rng
    
    Columns(Kol).Delete
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem Tamamlanmıştır....."
    Exit Sub
Son:
    MsgBox "A sütununda Link Verilecek Hücre Bulamadım ki İşlem Yapayım :)", vbCritical, "Necdet"
    
End Sub