Klasörden dosya çekmek

[Orion1]

Alternatif.
Aşağıdaki kodları deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Cancel = True
    ChDir (ThisWorkbook.Path & "\xxx")
    dosya = Application.GetOpenFilename(filefilter:="Excel Dosyaları(*.xls),(*.xls)", Title:="Excel Dosyasını Seçiniz. evrengizlen@hotmail.com")
    If dosya = False Then Exit Sub
    CreateObject("Shell.Application").Open dosya
End Sub

 

[sosorry]

Alternatif.
Aşağıdaki kodları deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
    If Target = "" Then Exit Sub
    Cancel = True
    ChDir (ThisWorkbook.Path & "\xxx")
    dosya = Application.GetOpenFilename(filefilter:="Excel Dosyaları(*.xls),(*.xls)", Title:="Excel Dosyasını Seçiniz. evrengizlen@hotmail.com")
    If dosya = False Then Exit Sub
    CreateObject("Shell.Application").Open dosya
End Sub

burda bu kodla klasörün nerde olduğunu soruyo, benim istediğim ilk kodda a1 hücresine a yazdığımda kalsörden a.xls yi açıyor. ancak ofisteki kitap isimleri 0874 xx asdf bey teras su yalıtımı.xls her seferinde böle isimleri girmektense ilk koda 0874 yazıp çift tıklamayla bu kitabı nasıl çağırabilirim?

 

[Orion1]

burda bu kodla klasörün nerde olduğunu soruyo, benim istediğim ilk kodda a1 hücresine a yazdığımda kalsörden a.xls yi açıyor. ancak ofisteki kitap isimleri 0874 xx asdf bey teras su yalıtımı.xls her seferinde böle isimleri girmektense ilk koda 0874 yazıp çift tıklamayla bu kitabı nasıl çağırabilirim?

Aşağıdaki kodu kullanın.
İçinde a1 hücresindeki herhengi bir kelime yazsanızda o kitap açılır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
Dim fso As Object, fs As Object
Dim dosya As String
    If Target = "" Then Exit Sub
    Cancel = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = (ThisWorkbook.Path & "\xxx")
    For Each fs In fso.getfolder(yol).Files
        If InStr(1, fs.Name, Range("A1").Value) > 0 Then
            Application.DisplayAlerts = False
            If Workbooks.Open(fs).ReadOnly = True Then Workbooks(fs.Name).Close False
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next
    MsgBox Range("A1").Value & " ile içeren bir dosya bulunamadı", vbCritical, "UYARI"
End Sub

 

[sosorry]

Aşağıdaki kodu kullanın.
İçinde a1 hücresindeki herhengi bir kelime yazsanızda o kitap açılır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
Dim fso As Object, fs As Object
Dim dosya As String
    If Target = "" Then Exit Sub
    Cancel = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = (ThisWorkbook.Path & "\xxx")
    For Each fs In fso.getfolder(yol).Files
        If InStr(1, fs.Name, Range("A1").Value) > 0 Then
            Application.DisplayAlerts = False
            If Workbooks.Open(fs).ReadOnly = True Then Workbooks(fs.Name).Close False
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next
    MsgBox Range("A1").Value & " ile içeren bir dosya bulunamadı", vbCritical, "UYARI"
End Sub

tamam ancak kitabın adını tamamen yazmak gerekiyor. ben sadece ilk 4 karakterini yazıp tanıtmak istiyorum. ekte verdim.

 

[Orion1]

tamam ancak kitabın adını tamamen yazmak gerekiyor. ben sadece ilk 4 karakterini yazıp tanıtmak istiyorum. ekte verdim.

Gelmez tabii ki.
Çünkü benim yazdığım kodları yazmamışsınız.
Hıııııı beni dinlemezseniz böyle olur işte.
Ben ne yazdıysam onu değiştirmeden aynisi copy paste yapın.

 

[sosorry]

Gelmez tabii ki.
Çünkü benim yazdığım kodları yazmamışsınız.
Hıııııı beni dinlemezseniz böyle olur işte.
Ben ne yazdıysam onu değiştirmeden aynisi copy paste yapın.

yaptım ancak a1 de yazanı açıyor hep. a4 e yazdığım kitap adını değil de a1 de yazılı olanı açıyor a4 e de çift tıkladığımda

 

[Orion1]

Durumu düzelttim.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
Dim fso As Object, fs As Object
Dim dosya As String
    If Target = "" Then Exit Sub
    Cancel = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = (ThisWorkbook.Path & "\xxx")
    For Each fs In fso.getfolder(yol).Files
        If InStr(1, fs.Name, Target.Value) > 0 Then
            Application.DisplayAlerts = False
            If Workbooks.Open(fs).ReadOnly = True Then Workbooks(fs.Name).Close False
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next
    MsgBox Range("A1").Value & " ile içeren bir dosya bulunamadı", vbCritical, "UYARI"
End Sub

 

[sosorry]

Durumu düzelttim.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Then Exit Sub
Dim fso As Object, fs As Object
Dim dosya As String
    If Target = "" Then Exit Sub
    Cancel = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    yol = (ThisWorkbook.Path & "\xxx")
    For Each fs In fso.getfolder(yol).Files
        If InStr(1, fs.Name, Target.Value) > 0 Then
            Application.DisplayAlerts = False
            If Workbooks.Open(fs).ReadOnly = True Then Workbooks(fs.Name).Close False
            Application.DisplayAlerts = True
            Exit Sub
        End If
    Next
    MsgBox Range("A1").Value & " ile içeren bir dosya bulunamadı", vbCritical, "UYARI"
End Sub

) eline sağlık ancak şimdi de sadece o dosyayı açıyor :S :S a2, a3 filan açmıyo

 

[Orion1]

) eline sağlık ancak şimdi de sadece o dosyayı açıyor :S :S a2, a3 filan açmıyo

Neden.Çünkü kodlar öyle.Ve siz öyle istediniz.
klasör içinde döngüye giriyor.
Her dosyaya tek tek bakıyor.
Neye bakıyor.tıkladığınız hücrenin içindeki değer o an döngüdeki dosyanın adının içinde varsa o dosyayı hemen açıyor.Yani bulduğu ilk dosyaya.mesela a1 ve a2 isimli 2 tane doysa olsun.tıkladığınız hücredeki değerde a olsun
önce a1 okunacalk ve isminin içinde a bulunduğu için o dosya hemen açılacak.Ve prosedürden çıkılacak.Sizin bu isteğiniz bu yüzden iyi tasarlanmamış bir düşünce.Ben o yüzden size ilk önce bir dosya yolladım oradan seçeseniz diye.Getopenfile açılıyor ve seçiyorsunuz.Ama siz onu değil bunu istediniz.

 

[musculus]

Şiir gibi çözüm bilgine sağlık

 

[sosorry]

selam
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Or Target = "" Then Exit Sub
Cancel = True
Dosya = Target.Text
If Dir$(ThisWorkbook.Path & "\xxx\" & Dosya & ".xls") <> "" Then
CreateObject("Shell.Application").Open ThisWorkbook.Path & "\xxx\" & Dosya & ".xls"
Else
MsgBox "Bu isimde bir dosya bulunmamaktadır.", vbCritical, "Dosya Bulunamadı"
End If
End Sub

bu kodu a1:a10 a kadar xxx kalsöründe ve d1:d10 a kadar yyy klasöründen dosya çekmesi için nasıl düzeltebilirim?

 

[Orion1]

selam
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10]) Is Nothing Or Target = "" Then Exit Sub
Cancel = True
Dosya = Target.Text
If Dir$(ThisWorkbook.Path & "\xxx\" & Dosya & ".xls") <> "" Then
CreateObject("Shell.Application").Open ThisWorkbook.Path & "\xxx\" & Dosya & ".xls"
Else
MsgBox "Bu isimde bir dosya bulunmamaktadır.", vbCritical, "Dosya Bulunamadı"
End If
End Sub

bu kodu a1:a10 a kadar xxx kalsöründe ve d1:d10 a kadar yyy klasöründen dosya çekmesi için nasıl düzeltebilirim?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10,D1:D10]) Is Nothing Or Target = "" Then Exit Sub
Cancel = True
Dosya = Target.Text
If Target.Column = 1 Then yol = "\xxx\"
If Target.Column = 4 Then yol = "\yyy\"
If Dir$(ThisWorkbook.Path & "\xxx\" & Dosya & ".xls") <> "" Then
CreateObject("Shell.Application").Open ThisWorkbook.Path & yol & Dosya & ".xls"
Else
MsgBox "Bu isimde bir dosya bulunmamaktadır.", vbCritical, "Dosya Bulunamadı"
End If
End Sub

 

[sosorry]

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [a1:a10,D1:D10]) Is Nothing Or Target = "" Then Exit Sub
Cancel = True
Dosya = Target.Text
If Target.Column = 1 Then yol = "\xxx\"
If Target.Column = 4 Then yol = "\yyy\"
If Dir$(ThisWorkbook.Path & "\xxx\" & Dosya & ".xls") <> "" Then
CreateObject("Shell.Application").Open ThisWorkbook.Path & yol & Dosya & ".xls"
Else
MsgBox "Bu isimde bir dosya bulunmamaktadır.", vbCritical, "Dosya Bulunamadı"
End If
End Sub

hata veriyo şöe yapabilir miyiz? a1:a10 arası çift tıkla xxx kasöründeki;
d1:d10 arası çift tıklamaları yyy klasöründen açmasını nasıl sağlayabiliriz?

 

[Orion1]

hata veriyo şöe yapabilir miyiz? a1:a10 arası çift tıkla xxx kasöründeki;
d1:d10 arası çift tıklamaları yyy klasöründen açmasını nasıl sağlayabiliriz?

Bu kod hata vermez.Tabbii ki siz tıkladığınız hücredeki dosuya o klasörde yoksa hata verir veye siizn çalıştırdığınız dosyanın bir altındaki sütuna göre xxx veya yyy klasörü yoksa yine hata verir.Kontrol ediniz.

 

[sosorry]

Bu kod hata vermez.Tabbii ki siz tıkladığınız hücredeki dosuya o klasörde yoksa hata verir veye siizn çalıştırdığınız dosyanın bir altındaki sütuna göre xxx veya yyy klasörü yoksa yine hata verir.Kontrol ediniz.

hmm ekledim dosyayı bakar mısınız?

 

[Orion1]

hmm ekledim dosyayı bakar mısınız?

Baktım.Problem yok.Kodlar gayet güzel çalışıyor.
Yalnızca abcd isimli exc el dosyası xxx klasöründe olmadığı için bulunamdı diye messaj veriyor.Diğer dosyaları açıyor.Problem gözükmüyor.
d sütununda veriniz olmadığı için onu denemedim.
Çift tıklamnazıu lazım

 

[sosorry]

Baktım.Problem yok.Kodlar gayet güzel çalışıyor.
Yalnızca abcd isimli exc el dosyası xxx klasöründe olmadığı için bulunamdı diye messaj veriyor.Diğer dosyaları açıyor.Problem gözükmüyor.
d sütununda veriniz olmadığı için onu denemedim.
Çift tıklamnazıu lazım

yyy klasörünün içindeki h.xls için bulunamadı diyor :S

 

[sosorry]

yardımm

 

[Orion1]

yardımm

yyy klasörü içinde h.xls dosyası yok ki zaten tabi öyle diyecek

Bana yolladığınız dosyada yoktu mesela h.xls yyy klasörü içinde.O x kalasörü üçnde vardı.

 

[sosorry]

yyy klasörü içinde h.xls dosyası yok ki zaten tabi öyle diyecek

Bana yolladığınız dosyada yoktu mesela h.xls yyy klasörü içinde.O x kalasörü üçnde vardı.

hmm hayret ya tekrar ekliyorum.