Köprüler siliniyor.

[magnesia]

#1
Option Compare Text
Sub kod2()
Set alan = Range("B3:B69,F3:F69,J3:J69,N3:N69")
ReDim dz(alan.Cells.Count - 1, 2)
a = 0
For Each hcr In alan
dz(a, 1) = hcr.Value
dz(a, 2) = hcr.Offset(0, 1).Value
a = a + 1
Next
For i = LBound(dz) To UBound(dz) - 1
For j = i + 1 To UBound(dz)
If dz(i, 1) > dz(j, 1) Then
x1 = dz(i, 1)
x2 = dz(i, 2)
dz(i, 1) = dz(j, 1)
dz(i, 2) = dz(j, 2)
dz(j, 1) = x1
dz(j, 2) = x2
End If
Next
Next
alan.ClearContents
alan.Offset(0, 1).ClearContents
a = 0
For Each hcr In alan
Do While dz(a, 1) = ""
a = a + 1
Loop
hcr.Value = dz(a, 1)
hcr.Offset(0, 1).Value = dz(a, 2)
a = a + 1
If a > UBound(dz) Then Exit For
Next
End Sub

Arkadaşlar selam.
Yukarıdaki kodlarla, bir sayfa içinde belirlediğimiz aralıklardaki verileri alfabetik şekilde sıralıyorum. Köprü aracılığıyla da belgelere ulaşabiliyorum.
Yalnız; yeni bir veri girip sırala butonuna bastığımda ayarladığım tüm köprüler kalkıyor..
Sebebi ve çözümü nedir?
Şimdiden teşekkürler.

(NOT : Bu konuyu gündüz açmıştım. Yanıt veren üstad çıkmayınca silip tekrar ekledim. Umarım bu sefer belki yanıt veren bir üstad çıkar.)

 

[PLİNT]

Merhaba
Kodlarda diziye sadece değerler alınıyor aşağıdaki gibi köprü yollarınıda ekleyerek yapabilirsiniz.
(Dosyanızın yedeğini alarak deneyin.)

Sub kod2()
Set alan = Range("B3:B69,F3:F69,J3:J69,N3:N69")
ReDim dz(alan.Cells.Count - 1, 2)
a = 0
For Each hcr In alan
dz(a, 1) = hcr.Value & "#"
If hcr.Hyperlinks.Count > 0 Then dz(a, 1) = dz(a, 1) & hcr.Hyperlinks(1).SubAddress
dz(a, 2) = hcr.Offset(0, 1).Value & "#"
If hcr.Offset(0, 1).Hyperlinks.Count > 0 Then dz(a, 2) = dz(a, 2) & hcr.Offset(0, 1).Hyperlinks(1).SubAddress
a = a + 1
Next
For i = LBound(dz) To UBound(dz) - 1
For j = i + 1 To UBound(dz)
If Split(dz(i, 1), "#")(0) > Split(dz(j, 1), "#")(0) Then
x1 = dz(i, 1)
x2 = dz(i, 2)
dz(i, 1) = dz(j, 1)
dz(i, 2) = dz(j, 2)
dz(j, 1) = x1
dz(j, 2) = x2
End If
Next
Next
alan.ClearContents
With alan.Font
        .OutlineFont = False
        .ColorIndex = xlAutomatic
End With
alan.Offset(0, 1).ClearContents
a = 0
For Each hcr In alan
Do While dz(a, 1) = "#"
a = a + 1
Loop
hcr.Value = Split(dz(a, 1), "#")(0)
If Split(dz(a, 1), "#")(1) <> "" Then ActiveSheet.Hyperlinks.Add hcr, "", Split(dz(a, 1), "#")(1)
hcr.Offset(0, 1).Value = Split(dz(a, 2), "#")(0)
If Split(dz(a, 2), "#")(1) <> "" Then ActiveSheet.Hyperlinks.Add hcr.Offset(0, 1), "", Split(dz(a, 2), "#")(1)
a = a + 1
If a > UBound(dz) Then Exit For
Next
End Sub

 

[magnesia]

Sayın Plint.
Öncelikle ilginize ve emeğinize teşekkür ederim. Kodları uyguladım fakat sonuç değişmedi.
Köprü ekledikten sonra sırala butonuna bastığımda köprüler tekrar silindi.

 

[PLİNT]

Aslında dosyanızın örneğini görmek daha iyi olurdu ama; yukarıdaki kodlar ek dosyada sıralama yaptıktan sonra köprüleri değerlerle beraber taşıyor.
https://we.tl/t-ETtq8cKOxo

 

[magnesia]

Şaşılacak bir durum... Sizin dosyanızda denedim oluyor fakat benim dosyada olmuyor.

 

[PLİNT]

Köprüler dosya dışı , başka belge içinmi acaba; öyle ise
İşaretli bölümde düzeltme yapıldı

Sub kod2()
Set alan = Range("B3:B69,F3:F69,J3:J69,N3:N69")
ReDim dz(alan.Cells.Count - 1, 2)
a = 0
For Each hcr In alan
dz(a, 1) = hcr.Value & "#"
If hcr.Hyperlinks.Count > 0 Then dz(a, 1) = dz(a, 1) & hcr.Hyperlinks(1).Address
dz(a, 2) = hcr.Offset(0, 1).Value & "#"
'....
If hcr.Offset(0, 1).Hyperlinks.Count > 0 Then dz(a, 2) = dz(a, 2) & hcr.Offset(0, 1).Hyperlinks(1).Address
'......
a = a + 1
Next
For i = LBound(dz) To UBound(dz) - 1
For j = i + 1 To UBound(dz)
If Split(dz(i, 1), "#")(0) > Split(dz(j, 1), "#")(0) Then
x1 = dz(i, 1)
x2 = dz(i, 2)
dz(i, 1) = dz(j, 1)
dz(i, 2) = dz(j, 2)
dz(j, 1) = x1
dz(j, 2) = x2
End If
Next
Next
alan.ClearContents
With alan.Font
         .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
End With
alan.Offset(0, 1).ClearContents
a = 0
For Each hcr In alan
Do While dz(a, 1) = "#"
a = a + 1
Loop
hcr.Value = Split(dz(a, 1), "#")(0)
If Split(dz(a, 1), "#")(1) <> "" Then ActiveSheet.Hyperlinks.Add hcr, Split(dz(a, 1), "#")(1)
hcr.Offset(0, 1).Value = Split(dz(a, 2), "#")(0)
If Split(dz(a, 2), "#")(1) <> "" Then ActiveSheet.Hyperlinks.Add hcr.Offset(0, 1), Split(dz(a, 2), "#")(1)
a = a + 1
If a > UBound(dz) Then Exit For
Next
End Sub

 

[magnesia]

Şimdi oldu sayın Plint...
İlginize, bilginize ve emeğinize teşekkürler...

 

[PLİNT]

Rica ederim kolay gelsin.
Umarım yukarıdaki (6.mesajdaki) son düzeltilmiş şeklini kullanmışsınızdır.