Farklı klasor dizinindeki sayfayı alma

[excellkurdu]

Merhabalar,
Form.xlsm adında dosya açıkken, aynı dizin altında ....\Musteri_Dosyasi\Data_Veri\ Data_Veri klasorundeki kapalı olan dosya içindeki ilgili sayfayı kopya almak istiyorum.
Almak istediğim Sayfa Veri!AR18 hücresinde olan adı değişken sayfadır. Kayıtlı makroda Dosya_Sec ve Kopya_Al makrolarında ad tanımlamada hata yapıyorum. Ama hatamı bulamadım. Faklı dizinden kaynaklı olabilir diye düşünüyorum. Yardımlarınızı rica ediyorum.

İndir deneme

Dosyayı indir deneme

dosya.co

Sub deneme()
Call dosya_ara
Call Dosya_Ac
Call Dosya_Sec
Call Kopya_Al
End Sub
Sub dosya_ara()
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(ThisWorkbook.Path & "\Musteri_Dosyasi\Data_Veri\" & [Veri!AR18] & ".xls")
If a = True Then
MsgBox "Data Bulundu"
Else
MsgBox "Data Bulunamadı!"
End If
End Sub
Sub Dosya_Ac()
     Dim ad As String, yol As String, hucre As String
      ad = [Veri!AR18] & ".xls"
      yol = ThisWorkbook.Path & "\Musteri_Dosyasi\Data_Veri\"
     CreateObject("Shell.Application").Open yol & ad
    ' MsgBox "Dosya açıldı."
    'Application.Wait (Now + TimeValue("0:00:20"))
End Sub
Sub Dosya_Sec()
     Dim ad As String, yol As String, hucre As String
      ad = [Veri!AR18] & ".xls" 'dosya adı
      hucre = [Veri!AR18] 'sayfa adı
      
      
        Windows(ad).Activate 'BURDA HATA VAR ??????
        
        
        Sheets(hucre).Select
       ' MsgBox "Dosya seçildi"
End Sub
Sub Kopya_Al()
     Dim ad As String, yol As String, hucre As String
      ad = [Veri!AR18] & ".xls" 'dosya adı
      hucre = [Veri!AR18] 'sayfa adı
    Sheets(hucre).Select
    Sheets(hucre).Copy Before:=Workbooks("Form.xlsm").Sheets(1)
    Sheets("ServisFORMU").Select
End Sub

 

[Korhan Ayhan]

İlgili dosya kayıtlı ise hata vermemesi gerekir.

Kayıtlı değilse dosyanın uzantısını silerek ilgili satırı çalıştırıp deneyin.

 

[excellkurdu]

İlgili dosya kayıtlı ise hata vermemesi gerekir.

Kayıtlı değilse dosyanın uzantısını silerek ilgili satırı çalıştırıp deneyin.

Dosya kayıtlı. Dizin olarak tüm dosyaları ekledim. Bakarsanız sevinirim.

 

[Korhan Ayhan]

Kullandığınız kodları denediğimde dosya açma işlemi ve seçme işlemi yapan kodlarınız bende çalışmadı.

Aşağıdaki gibi düzenledim.

Sub Dosya_Ac()
    Dim ad As String, yol As String, hucre As String
    ad = [Veri!AR18] & ".xls"
    yol = ThisWorkbook.Path & "\Musteri_Dosyasi\Data_Veri\"
    Workbooks.Open yol & ad
End Sub

Sub Dosya_Sec()
    Dim ad As String, yol As String, hucre As String
    
    Windows("Form.xlsm").Activate
    ad = [Veri!AR18] & ".xls"
    hucre = [Veri!AR18]
      
    Windows(ad).Activate
    Sheets(hucre).Select
End Sub

Bu haliyle kod yine hata veriyor. Sebebi de "Data001.xls" dosyasının içinde ki sayfa adı "Data003" olarak kayıt edilmiş. Sayfa isimleri eşleşmediği için hata vermektedir. Düzeltirseniz kodlar çalışacaktır.

Ama ben olsam dosya ve sayfa isimlerini SET'leyerek kullanma yöntemini denerdim. Aşağıdaki kod bu yapıda kurgulanmıştır.

Sub Sheet_Copy()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, S2 As Worksheet
    Dim File_Path As String, File_Name As String, Sheet_Name As String

    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("ServisFORMU")
    Set S2 = K1.Sheets("Veri")

    File_Path = K1.Path & "\Musteri_Dosyasi\Data_Veri\"
    File_Name = File_Path & S2.Range("AR18").Value & ".xls"
    Sheet_Name = S2.Range("AR18").Value

    If Dir(File_Name, vbNormal) = "" Then
        MsgBox File_Name & " dosyası bulunamadı!" & vbCr & vbCr & _
               "Bu sebeple işleme devam edilemiyor!", vbCritical
        Exit Sub
    Else
        Application.ScreenUpdating = False
        Set K2 = Workbooks.Open(File_Name, False, False)
        Application.ScreenUpdating = True
        On Error Resume Next
        Set S2 = Nothing
        Set S2 = K2.Sheets(Sheet_Name)
        On Error GoTo 0
        If Not S2 Is Nothing Then
            S2.Copy Before:=K1.Sheets(1)
            K2.Close False
            K1.Activate
            S1.Select
            MsgBox "Sayfa kopyalama işlemi tamamlanmıştır.", vbInformation
        Else
            K2.Close False
            MsgBox File_Name & " dosyası içinde aşağıdaki sayfa bulunamadı!" & vbCr & vbCr & _
                   "Bu sebeple işlem sonlandırılmıştır!" & vbCr & vbCr & Sheet_Name, vbCritical
        End If
    End If

    Set K1 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[excellkurdu]

Kullandığınız kodları denediğimde dosya açma işlemi ve seçme işlemi yapan kodlarınız bende çalışmadı.

Aşağıdaki gibi düzenledim.

Sub Dosya_Ac()
    Dim ad As String, yol As String, hucre As String
    ad = [Veri!AR18] & ".xls"
    yol = ThisWorkbook.Path & "\Musteri_Dosyasi\Data_Veri\"
    Workbooks.Open yol & ad
End Sub

Sub Dosya_Sec()
    Dim ad As String, yol As String, hucre As String
   
    Windows("Form.xlsm").Activate
    ad = [Veri!AR18] & ".xls"
    hucre = [Veri!AR18]
     
    Windows(ad).Activate
    Sheets(hucre).Select
End Sub

Bu haliyle kod yine hata veriyor. Sebebi de "Data001.xls" dosyasının içinde ki sayfa adı "Data003" olarak kayıt edilmiş. Sayfa isimleri eşleşmediği için hata vermektedir. Düzeltirseniz kodlar çalışacaktır.

Ama ben olsam dosya ve sayfa isimlerini SET'leyerek kullanma yöntemini denerdim. Aşağıdaki kod bu yapıda kurgulanmıştır.

Sub Sheet_Copy()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, S2 As Worksheet
    Dim File_Path As String, File_Name As String, Sheet_Name As String

    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("ServisFORMU")
    Set S2 = K1.Sheets("Veri")

    File_Path = K1.Path & "\Musteri_Dosyasi\Data_Veri\"
    File_Name = File_Path & S2.Range("AR18").Value & ".xls"
    Sheet_Name = S2.Range("AR18").Value

    If Dir(File_Name, vbNormal) = "" Then
        MsgBox File_Name & " dosyası bulunamadı!" & vbCr & vbCr & _
               "Bu sebeple işleme devam edilemiyor!", vbCritical
        Exit Sub
    Else
        Application.ScreenUpdating = False
        Set K2 = Workbooks.Open(File_Name, False, False)
        Application.ScreenUpdating = True
        On Error Resume Next
        Set S2 = Nothing
        Set S2 = K2.Sheets(Sheet_Name)
        On Error GoTo 0
        If Not S2 Is Nothing Then
            S2.Copy Before:=K1.Sheets(1)
            K2.Close False
            K1.Activate
            S1.Select
            MsgBox "Sayfa kopyalama işlemi tamamlanmıştır.", vbInformation
        Else
            K2.Close False
            MsgBox File_Name & " dosyası içinde aşağıdaki sayfa bulunamadı!" & vbCr & vbCr & _
                   "Bu sebeple işlem sonlandırılmıştır!" & vbCr & vbCr & Sheet_Name, vbCritical
        End If
    End If

    Set K1 = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Hocam çok sağolun. Verdiğiniz bu kod çok kullanışlı. Allah razı olsun