Metin veya şekil kutularını seri doldurma ve Link atama

[tahsinanarat]

A sutunundaki dolap numaralarını Kroki sayfasında eşleşen kutucukların içindeki rakamları otomatik link atamak istiyorum,
Not: Kroki sayfasındaki kutucukların içini ben manuel olarak girdim, bunun seri bir şekilde makro ile doldurulması mümkün müdür. Yardımcı olacak arkadaşlarıma şimdiden teşekkürler.

 

[askm]

Aşağıdaki kodları deneyin.

Sub ASKM()

Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Kroki")
For i = 2 To Sheets("Dolaplar").Range("A" & Rows.Count).End(3).Row
    With ActiveSheet.Shapes.Range(i)
        Set hyperLinkedShape = ws.Shapes(i)
        .TextFrame2.TextRange.Characters.Text = Sheets("Dolaplar").Range("B" & i)
        ws.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:="", _
        SubAddress:="Dolaplar!A" & i, ScreenTip:="Şekil"
    End With
Next i
    
End Sub

 

[tahsinanarat]

Sn. askm,
.TextFrame2.TextRange.Characters.Text = Sheets("Dolaplar").Range("B" & i)
satırında hata alıyorum
.TextFrame2.TextRange.Characters.Text = Sheets("Dolaplar").Range("a" & i)
olarak da denedim ama yine hata aldım, satır sarıya boyandı

 

[veyselemre]

 With ws.Shapes.Range(i)

 

[tahsinanarat]

Sn. veyselemre hocam elinize sağlık, şekillere serileri girip şekildeki sayı üzerine tıkladığımda Dolaplar sayfasında a sütununda eşleşen hücreye gidiyor. Buraya kadar tamam.
A sütunundaki sayıya da link atayıp Kroki sayfasındaki şekili seçtirebilirsek bu işlem tamam olacaktır. Şimdiden teşekkür ederim. Yani karşılıklı link atayacak.

 

[veyselemre]

Modüle Ekleyin;

Sub shpTextEkle()
    Set sk = Sheets("Kroki")
    Set sd = Sheets("Dolaplar")

    sk.Hyperlinks.Delete
    sd.Hyperlinks.Delete

    son = sd.Cells(Rows.Count, 1).End(3).Row

    Set shp = sk.Shapes
    For Each sh In shp
        shpNo = Val(sh.Name)
        If shpNo <= son - 1 Then
            sh.TextFrame2.TextRange.Text = sd.Cells(shpNo + 1, 2).Text
            sk.Hyperlinks.Add Anchor:=sh, Address:="", SubAddress:="Dolaplar!A" & shpNo + 1
            sd.Hyperlinks.Add Anchor:=sd.Cells(shpNo + 1, 1), Address:="", SubAddress:=""
        End If
    Next
End Sub
Sub tıklandı()
    MsgBox Application.Caller
End Sub

Dolaplar sayfasının kod modülüne ekleyin,

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Set sk = Sheets("Kroki")
    For Each sh In sk.Shapes

        If sh.Name = Trim(Target.Parent) Then
            sk.Select
            sh.Select
            Exit For
        End If
    Next
End Sub

 

[tahsinanarat]

Sn.veyselemre, Emeğiniz için teşekkür ederim, fakat bütün şekillere b1 deki değeri veriyor, yani bütün kutucuklar SİCİLİ diye doluyor.

 

[veyselemre]

Sn.veyselemre, Emeğiniz için teşekkür ederim, fakat bütün şekillere b1 deki değeri veriyor, yani bütün kutucuklar SİCİLİ diye doluyor.

Kodlar ilk mesajınızdaki dosyaya uygundur, indirin deneyin.

 

[tahsinanarat]

Sn. veyselemre, örnekteki kutucukları ben kendi numaralarını vererek her şekili adlandırmıştım, boş olduklarında seri şekilde doldurulmasını istemiştim. İlginize çok teşekkür ediyorum, bunu da öğrenmiş olduk.