Birçok çalışma kitabını bir araya toplamak

[manisali61]

Arkadaşlar merhaba..
Elimdeki çalışma kitaplarını tek bir kitap içine almak ve kategorilerine göre (araçlar,personel,vb..) biraraya getirip o konu ile ilgili kitabın üzerine tıklayarak o kitabı açmak istiyorum..Yardımcı olursanız sevinirim.
Şimdiden teşekkürler

 

[manisali61]

Forumumuza bugünlerde birşeyler oldu arkadaşlar..

 

[rahmi06]

Köprü işini görür sanırım.

 

[manisali61]

Doğru arkadaşım..Köprü işimi gördü.Bunları buton şekline getirebilir miyim??

 

[rahmi06]

Private Sub CommandButton2_Click()
Workbooks.Open Filename:="D:\Dosya adı.xls"
End Sub

Kırmızı dosya adını kendinize göre düzenleyiniz.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Basla()
Dim Klasor As Object
Set Klasor = CreateObject("Shell.Application").BrowseForFolder _
                    (0, "Lütfen bir klasor seçin !", 1)
                    
If Klasor Is Nothing Then Exit Sub
Range("A2:A65536").Clear
[A1] = "Dosya Yolu ve Dosya Adı"
Liste (Klasor.Items.Item.Path)
AltListe (Klasor.Items.Item.Path)
 
Set Klasor = Nothing
End Sub

Sub Liste(yol As String)
Dim dosya As String, i As Long
 
    dosya = Dir(yol & "\*.xls")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
End Sub

Sub AltListe(yol As String)
Dim fL As Object, f As Object, dosya As String, j As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).SubFolders
 
On Error GoTo sonraki
For Each f In fL
    dosya = Dir(f.Path & "\*.*")
    
    While dosya <> ""
        DoEvents
        j = [a65000].End(3).Row + 1
        Cells(j, 1) = yol & "\" & dosya
        dosya = Dir
    Wend
    
    AltListe (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

İlgili sayfada olması gereken kod :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
If Target.Row < 2 Then Exit Sub
If Target.Value = "" Then Exit Sub
Workbooks.Open Target.Value
ActiveWorkbook.RunAutoMacros xlAutoOpen
End Sub

Dizindeki xl dosyaların adlarını A sütununa aldıktan sonra A sütunundaki bir hücreye Çift Tıklarsanız dosyayı açar.

 

[Necdet]

Forumumuza bugünlerde birşeyler oldu arkadaşlar..

Sıcaklardandır



.

 

[Orion1]

Sıcaklardandır



.

Hocam denizemi kaçsak ne yapsak!!!!

 

[Necdet]

Hocam denizemi kaçsak ne yapsak!!!!

Evren bey angarada deniz de yokki nereye kaçak. En iyisi çalışmaya devam

 

[Orion1]

Evren bey angarada deniz de yokki nereye kaçak. En iyisi çalışmaya devam

Burada olunca ankarayı unuttuk
Size en yakın abant galiba hocam.

 

[Necdet]

valla Evren hocam bu sıcakta ben aaayatta dışarı çıkmam