Sayfadaki Köprüleri Değiştirme

[askm]

İyi akşamlar.
İki sorum olacak.
1.Sayfa içerisinde masaüstünde olan bir klasör köprü kurulmuş. Farklı bir bilgisayarda çalışmıyor. Bu köprüleri toplu olarak masaüstü olacak şekilde nasıl değiştirebilirim.
2. Klasör içerisinde bulunan klasörlere A sütununda altındaki dosyaları B sutununda listeleyip köprü ekleyebilir miyim.
Teşekkürler.

 

[askm]

2. Soru için örnek dosya ekliyorum.

 

[halit3]

kod:

Dim sat1 As String

Sub deneme()

a = MsgBox("Klasörün içindeki dosyaların sayfalarının adını yazdırmak istiyormusunuz.?", vbYesNo + vbInformation, " uyarı")
If a = vbNo Then
Exit Sub
End If

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

sat1 = 2
Liste (Kaynak)

Application.DisplayAlerts = False

MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, Dosya As Object

Set fL = CreateObject("Scripting.FileSystemObject")
Cells(sat1, 1) = yol
sat1 = sat1 + 1
For Each Dosya In fL.GetFolder(yol).Files

Uzanti = fL.GetExtensionName(Dosya)

Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya.Name And fL.GetFile(Dosya).Type = "Microsoft Excel Çalışma Sayfası" Then

Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Dosya_Yolu = (Dosya)
If Uzanti = "xls" Or Uzanti = "xlsb" Or Uzanti = "xlsx" Or Uzanti = "xlsm" Then

sut = 3
On Error Resume Next

If Uzanti = "xls" Then
Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Dosya_Yolu & ";"
Else
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
End If

Cells(sat1, 3) = "Çalışma kitabı korumalı"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
If sut = Columns.Count Then
sut = 3
sat1 = sat1 + 1
End If

Cells(sat1, sut).Hyperlinks.Add Anchor:=Cells(sat1, sut), Address:=Dosya, SubAddress:=Left$(son1, Len(son1) - 1) & "!A1", TextToDisplay:=Left$(son1, Len(son1) - 1)

sut = sut + 1
End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing
Cells(sat1, 2).Hyperlinks.Add Anchor:=Cells(sat1, 2), Address:=Dosya, SubAddress:="" & firstAddress, TextToDisplay:=Dosya.Name 'fL.GetBaseName(Dir(Dosya))
If Cells(sat1, 3) = "Çalışma kitabı korumalı" Then
sat1 = sat1 + 1
End If
sat1 = sat1 + 1
End If
End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Kaynak = f.Path

Liste (Kaynak)
sonraki:
Next

Set fL = Nothing
End Sub

 

[askm]

Halit Bey çok teşekkür ederim. Yalnız biraz fazla detay olmuş. Benim istediğim tüm dosyaları listelemesi. Ve klasörlere de köprü eklemesi şeklinde. Yani A sütunundaki köprüyü tıklayınca klasör açılacak. B sütunundaki word , excel ya da pdf evrağı tıklayınca onlar açılacak.

 

[askm]

Örnek dosya ekledim.

 

[halit3]

Halit Bey çok teşekkür ederim. Yalnız biraz fazla detay olmuş. Benim istediğim tüm dosyaları listelemesi. Ve klasörlere de köprü eklemesi şeklinde. Yani A sütunundaki köprüyü tıklayınca klasör açılacak. B sütunundaki word , excel ya da pdf evrağı tıklayınca onlar açılacak.

kod:

Dim sat1 As String

Sub deneme()

a = MsgBox("Klasörün içindeki dosyaların sayfalarının adını yazdırmak istiyormusunuz.?", vbYesNo + vbInformation, " uyarı")
If a = vbNo Then
Exit Sub
End If

Cells.ClearContents
Cells.Hyperlinks.Delete
Cells.Font.ColorIndex = 0

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

sat1 = 2
Liste (Kaynak)

Application.DisplayAlerts = False

MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object, Dosya As Object

Set fL = CreateObject("Scripting.FileSystemObject")
Cells(sat1, 1).Hyperlinks.Add Anchor:=Cells(sat1, 1), Address:=yol, SubAddress:="" & firstAddress, TextToDisplay:=yol 'fL.GetBaseName(Dir(Dosya))
For Each Dosya In fL.GetFolder(yol).Files
Uzanti = fL.GetExtensionName(Dosya)

Application.DisplayAlerts = False
If Mid(Dosya.Name, 1, 2) <> "~$" Then
If ThisWorkbook.Name <> Dosya.Name Then

'On Error Resume Next

Cells(sat1, 2).Hyperlinks.Add Anchor:=Cells(sat1, 2), Address:=Dosya, SubAddress:="" & firstAddress, TextToDisplay:=Dosya.Name 'fL.GetBaseName(Dir(Dosya))
Cells(sat1, 3).Value = Format(fL.GetFile(Dosya).Size / 1024, "#,##0.0000") & " Kb"

sat1 = sat1 + 1
End If
End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Kaynak = f.Path

Liste (Kaynak)
sonraki:
Next

Set fL = Nothing
End Sub

 

[askm]

Çok teşekkür ederim.Elinize sağlık.

 

[askm]

Bir sorum daha olabilirse yardımcı olursanız sevinirim.
Daha önceden manuel olarak köprü oluşturulmuş bir belgede A C E sütunlarında listelerde köprüler var. D içerisinde bir klasörden belge açıyor. Burdaki D klasör yerine thisworkbook olarak yani çalışma kitabının altında klasör gibi değiştirme imkanı olur mu.