Soru Dosyaya sadece göstereceğim klasör ve altında açılmasını sağlamak

[bulentkars]

Merhaba,

Aşağıdaki Kod Hesaplarım.xlsm dosyasının "O:\Ortak\TALIMATLAR\ARACLAR" haricinde başka bir yerden açıldığında izin vermiyor.
Burada yapmak istediğim;
Hesaplarım.XLSM Dosyası "O:\Ortak\TALIMATLAR\ARACLAR" ve altında da farklı klasörler varsa orada açılmasına izin vermesini istiyorum.

örneğin.

Mevcut Durum
"O:\Ortak\TALIMATLAR\ARACLAR"

Yapmak istediğim
"O:\Ortak\TALIMATLAR\ARACLAR\ve altında olan klasörlerin altında açılmasını istiyorum

yardcımcı olabilirseniz sevinirim. Şimdiden Teşekkürler

Sub Dosya_Kontrol()
If ThisWorkbook.Path = "O:\Ortak\TALIMATLAR\ARACLAR" Then

'MsgBox "açıl"
Else
MsgBox "Talimatlar Dosyası Sadece O:\Ortak\TALIMATLAR\ARACLAR Klasöründen açılır.", vbCritical, Application.UserName

ActiveWindow.Close SaveChanges:=False ' Dosyayı Kapatır

End If
End Sub

 

[Haluk]

    If Not ThisWorkbook.Path Like "O:\Ortak\TALIMATLAR\ARACLAR*" Then
        ActiveWindow.Close SaveChanges:=False
    End If

.

 

[dEdE]

Farklı bir yaklaşım. Mevcut kodunuza küçük bir ek.Left(ThisWorkbook.Path, 27)=

Sub Dosya_Kontrol()
    If Left(ThisWorkbook.Path, 27) = "O:\Ortak\TALIMATLAR\ARACLAR" Then
        MsgBox "açıl"
    Else
        MsgBox "Talimatlar Dosyası Sadece O:\Ortak\TALIMATLAR\ARACLAR Klasöründen açılır.", vbCritical, Application.UserName
        ActiveWindow.Close SaveChanges:=False ' Dosyayı Kapatır
    End If
End Sub

 

[bulentkars]

Sayın dEdE
Sayın Haluk Bey; ilginiz için çok teşekkür ederim.elinize sağlık

 

[bulentkars]

Merhaba,

Sayın dede nin kodu oldu, anacak anlayamadığım bir sorun var yardımcı olursanız sevinirim.
O:\Ortak\TALIMATLAR\ARACLAR\Hesaplar.xlsm dosyasını sadece ilgili yerede ve alt klasörlerde açabiliyorum. sorun yok,

ancak; aşağıdaki kod O:\ORTAK\TALIMATLAR\ARACLAR\HESAP\YEDEK\ altındaki tüm xlsm dosyaları açarak alt alta birleşiriyor,
birleştirme yaparken MsgBox "Talimatlar Dosyası Sadece O:\Ortak\TALIMATLAR\ARACLAR Klasöründen açılır.", vbCritical, Application.UserName
uyarıyı veriyor. dosyayı gidip kendi yolundan açtığımda bu uyarıyı vermiyor, ama aşağıdaki kod üzerinden çalıştırğımda uayarı veriyor. uyarı vermemesi için ne yapmalıyım acaba.
Yardımcı olabilirseniz sevinirim.


Sub Dosyalardan_Veri_Alll()

Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet


ThisWorkbook.Activate

Set S1 = Sheets("Log")


yol = "O:\ORTAK\TALIMATLAR\ARACLAR\HESAP\YEDEK\"
Dosya = Dir(yol & "\*.xls*")
Sayfa = Array("Grup", "320", "329")


Application.ScreenUpdating = False
S1.Range("A2:F" & Rows.Count).ClearContents 'eğer eski veriler silinmeyecekse bu satırı silersiniz.
sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1

Do While Dosya <> ""
Workbooks.Open yol & Dosya


' Workbooks.Open Filename:=yol & Dosya, Password:="123" açılış paralosavı varsa kaldırır
For i = 0 To UBound(Sayfa)
With Sheets(Sayfa(i))
say = i

.Unprotect "24062003"
If S1.Range("A1") = "" Then
.Range("A1:E1").Copy S1.Range("A1")
S1.Range("A1").Copy S1.Range("F1")
S1.Range("F1") = "Sayfa Adı"
End If
son = .Cells(Rows.Count, "E").End(xlUp).Row
If son > 1 Then
.Range("A1:E" & son).AutoFilter Field:=5, Criteria1:="<>"
.Range("A2:E" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
a = sat
sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
S1.Cells(a, "F").Resize(sat - a, 1) = .Name
End If
.Protect "24062003"
End With
Next i

Workbooks(Dosya).Close False
Dosya = Dir

Loop

S1.Columns("F:F").HorizontalAlignment = xlLeft
S1.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True

MsgBox say & " Adet Yedeklenmiş İban İşleminiz Başarıyla Tamamlandı.", vbInformation

End Sub