Köprü Oluşturma veya Alternatif Yöntem.

[ccuneyt13]

Merhaba. Örnek dosyadaki gibi bir liste oluşturmaya çalışıyorum. Fakat bir sorunum var ve değerli fikirlerinize ihtiyaç duymaktayım. Mesela Merkez sayfasında Orman olarak köprülenmiş olan hücre A47 de. Ama bu listede bi satır ekleme veya silme yaptığımda haliyle köprü bozuluyor ve her ekleme çıkarma işleminde tekrar köprü yapmak çok zor. Liste henüz oluşmadığı için örnek olarak hazırladım.

Bu mantıkla hem Fihrist te ilgili yerdeki ilgili isme tıkladığımda o sayfa ve o isme gidecek şekilde hemde var olan listede ekleme silme vs. yaptığımda hücre numarasını değilde sayfa ismi ve liste başlarında yazan başlıkları baz alacak şekilde düzenleme yapacak makro yada formülle olur mu.

Bu konuda bana bir fikir ve çözüm öneriniz olursa çok memnun olurum.

Not : Örnek Dosya aşağıdadır.
Saygılarımla.

 

[ccuneyt13]

dosya eklemede bir limit veya kotamı var acaba. bir türlü örnek ekleyemiyorum.

 

[ccuneyt13]

Sonunda örnek dosya ekleye bildim sanırım.

 

[İhsan Tank]

Sonunda örnek dosya ekleye bildim sanırım.

Merhaba
Sayfada bulunan linkleri kaldırın bu kodu sayfanın kod bölümüne uygulayın boş hücreye tıklayın boş boşta çalışıyor

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ts, kaplan, bordo
If Intersect(Target, Range("A2:O65536")) Is Nothing Then Exit Sub
kaplan = Target
Sheets(Cells(1, Target.Column).Text).Select
Set ts = ActiveSheet.Range("A:J").Find(kaplan, , , xlWhole)
If Not ts Is Nothing Then
bordo = ts.Address
Do
ActiveSheet.Range(ts.Address).Select
Set ts = ActiveSheet.Range("A:J").FindNext(ts)
Loop While Not ts Is Nothing And ts.Address <> bordo
End If
End Sub

 

[ccuneyt13]

Merhaba
Sayfada bulunan linkleri kaldırın bu kodu sayfanın kod bölümüne uygulayın boş hücreye tıklayın boş boşta çalışıyor

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ts, kaplan, bordo
If Intersect(Target, Range("A2:O65536")) Is Nothing Then Exit Sub
kaplan = Target
Sheets(Cells(1, Target.Column).Text).Select
Set ts = ActiveSheet.Range("A:J").Find(kaplan, , , xlWhole)
If Not ts Is Nothing Then
bordo = ts.Address
Do
ActiveSheet.Range(ts.Address).Select
Set ts = ActiveSheet.Range("A:J").FindNext(ts)
Loop While Not ts Is Nothing And ts.Address <> bordo
End If
End Sub

İhsan bey bir harikasınız valla. Allah bin kere razı olsun o kadar çok işime yarıyacak ki anlatamam. Elinize sağlık. Çok saolun.

 

[İhsan Tank]

İhsan bey bir harikasınız valla. Allah bin kere razı olsun o kadar çok işime yarıyacak ki anlatamam. Elinize sağlık. Çok saolun.

Allah Sizden de Razı Olsun
Kolay gelsin
:yazici: