• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Sayfa isimlerini listelemek ve köprülerini oluşturmak

T

towcu77

Katılım
14 Şubat 2005
Mesajlar
7
Arkadaşlar merhabalar,
Kargo ve diğer gönderilere etiket yazdırmak için kullanmakta olduğum bir excel dosyam var,
her sayfada müşteri sevk adresi bilgileri mevcut.Daha önceki konularda bir formül buldum ama benim tarafımda bazı farklı isteklerim olacak :)
daha önceki excel dosyasında yaklaşık 3000 sayfa vardı ve vakti zamanında bunlar için sayfa1'e tek tek sayfa isimleri elle yazılmış ve köprü yapılmış,
yeni bir dosya oluşturacağım ve istediğim;
Sayfa1'e (ya da anasayfaya) excel dosyasındaki tüm sayfa isimlerinin köprülü bir şekilde gelmesi,
aşağıdaki formülde her sayfada a1 hücresine verilen anasayfa linkinin g4 hücresine verilmesi,
yine aşağıdaki formülde her kolona 25 adet olarak verilmiş, ben tek kolonda aşağı doğru ilerlemesini istiyorum (ki ctrl+f ile istediğim sayfayı bulabiliyorum)
ve son olarak ta her yeni sayfa eklendiğinde veya sayfa ismi değiştiğinde anasayfadaki fihristte aynı değişikliğin otomatik yapılabilmesi,

ne dersiniz arkadaşlar, bu hasta yaşar mı :):)

bu acemi arkadaşınıza yardımlarınız için şimdiden teşekkür ediyorum,


eski konuların içerisinde bulduğum formül aşağıdaki gibidir,
ayrıca formül için sayın @asri'ye teşekkür ediyorum,

SayfaIndex adında sayfayı yeniden oluşturup, tüm sayfaların sayfa adlarını bu sayfada her bir kolonda 25 sayfa olacak şekilde köprü yapar.
Aynı zamanda her bir sayfanın A1 hücresine SayfaIndex sayfasına köprü yapar.
Tüm sayfaların A1 hücreleri boş olmak zorundadır.

Kod:
Sub SayfaIndex()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If WorksheetExists("SayfaIndex") Then Sheets("SayfaIndex").Delete
Set NewSh = Sheets.Add(Before:=Sheets(1))
NewSh.Name = "SayfaIndex"

Cells.ClearContents
kolon = 1
satir = 2
Cells(1, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="SayfaIndex!A1", TextToDisplay:="SayfaIndex"

For i = 2 To Sheets.Count
Cells(satir, kolon).Value = Sheets(i).Name
Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Cells(1, 1), Address:="", SubAddress:="SayfaIndex!A1", TextToDisplay:="SayfaIndex"
ActiveSheet.Hyperlinks.Add Anchor:=Cells(satir, kolon), Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
satir = satir + 1
If satir = 26 Then
kolon = kolon + 1
satir = 2
End If
Next i

Cells.Select
Cells.EntireColumn.AutoFit
Range("E1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
 
Aşağıdaki şekilde deneyiniz.

Anasayfa her aktif edildiğinde index yeniden oluşturulmaktadır.
20-30 sayfada pek fark edilmiyor ancak 1000-3000 sayfada nasıl bir durum oluşuyor deneyip bildirir misiniz?


Kod: 
'Anasayfa   sayfasının kod bölümüne aşağıdaki kodu ekleyin.
Private Sub Worksheet_Activate()
  Call linkolustur
End Sub

'Modul1'e aşağıdaki kodu ekleyin.
Sub linkolustur()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If WorksheetExists("Anasayfa") Then
   Cells.Clear
Else
    Set NewSh = Sheets.Add(Before:=Sheets(1))
    NewSh.Name = "Anasayfa"
End If

For i = 2 To Sheets.Count
Sheets("Anasayfa").Cells(i, "A").Value = Sheets(i).Name
Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Cells(4, "G"), Address:="", SubAddress:="Anasayfa!A1", TextToDisplay:="Anasayfa"
Sheets("Anasayfa").Hyperlinks.Add Anchor:=Sheets("Anasayfa").Cells(i, "A"), Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
Next i

Sheets("Anasayfa").Cells.EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
 
@asri hocam selamlar,
kullandığım excelde şu an aktif olarak 3269 sayfa var,ilk mesajımda da bahsettiğim üzere hepsinde adres mevcut, ayrıca firma logosu da var,
logodan kaynaklı hem dosya boyutu büyüyor (16 mb. ulaştı), hem de excel yavaş çalışmaya başlıyor, bu yüzden yeni ve güncel bir dosya oluşturacağım (logosuz :) )
ama işin özü verdiğiniz kodlar süper çalışıyor, çok çok teşekkür ediyorum, (y)(y)(y)
 
PriveT' Alıntı:
Merhaba,
Bir üstadımız yapmış, ben de arşivime eklemişim.
Kim olduğunu malesef hatırlamıyorum. Yapanın emeğine sağlık.
Sanırım istediğiniz böyle bir dosya.

https://dosya.co/svei3zwubzmn/sayfaları_ana_sayfaya_köprüle_MAKROSU.xls.html
Genişletmek için tıkla ...

@PriveT hocam merhabalar,
verdiğiniz dosya da işimi görüyor fakat, @asri hocanın verdiği kodlar ile tabiri caizse cuk oturdu,
ilginiz ve yardımlarınız için çok teşekkür ederim,
saygılar :)
 
asri' Alıntı:
Aşağıdaki şekilde deneyiniz.

Anasayfa her aktif edildiğinde index yeniden oluşturulmaktadır.
20-30 sayfada pek fark edilmiyor ancak 1000-3000 sayfada nasıl bir durum oluşuyor deneyip bildirir misiniz?


Kod: 
'Anasayfa   sayfasının kod bölümüne aşağıdaki kodu ekleyin.
Private Sub Worksheet_Activate()
  Call linkolustur
End Sub

'Modul1'e aşağıdaki kodu ekleyin.
Sub linkolustur()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If WorksheetExists("Anasayfa") Then
   Cells.Clear
Else
    Set NewSh = Sheets.Add(Before:=Sheets(1))
    NewSh.Name = "Anasayfa"
End If

For i = 2 To Sheets.Count
Sheets("Anasayfa").Cells(i, "A").Value = Sheets(i).Name
Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Cells(4, "G"), Address:="", SubAddress:="Anasayfa!A1", TextToDisplay:="Anasayfa"
Sheets("Anasayfa").Hyperlinks.Add Anchor:=Sheets("Anasayfa").Cells(i, "A"), Address:="", SubAddress:="'" & Sheets(i).Name & "'!A1", TextToDisplay:=Sheets(i).Name
Next i

Sheets("Anasayfa").Cells.EntireColumn.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name <> "")
On Error GoTo 0
End Function
Genişletmek için tıkla ...

@asri hocam selamlar,
kullandıkça ihtiyaçlar ortaya çıkıyor :)
bu kodun içine anasayfaya gelen linklerin alfabetik sıra ile gelmesi için ekleme yapabilir miyiz acaba ?
 
Merhaba,
Asri hocanın link oluştur makrosunun son satırı olarak
Kod: 
sonsatir = Cells(Rows.Count, "A").End(3).Row
Range("A2:A" & sonsatir).Sort [A2], Order1:=xlAscending
ekleyiniz.
İyi çalışmalar
 
Son düzenleme:
Rica ederim,
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst