Kapalı Dosyadan Veri Almak

[ormann]

İyi günler;
Ekli örnek dosyada veri girişi sayfasında D56 ve E11:L41 hücresine yine başka bir herhangi bir kapalı dosyadan yine veri girişi sayfasındaki D56 ve E11:L41 hücrelerine buton ile sadece değerleri alabilirmiyiz.?
Not: Kapalı dosyadaki D56 hücresindeki veriler yine D56 hücresine alınacak
Not: Kapalı dosyadaki E11:L41 hücresindeki veriler yine D56 hücresine alınacak

http://dosya.co/lvvbus3kspqa/örnek.xls.html

 

[ormann]

Konuya yardımcı olur musunuz?

 

[Korhan Ayhan]

Deneyiniz.

"Yol" tanımlamasındaki dosyadan veri alınmaktadır. Kendinize göre uyarlarsınız.

Kapalı dosyadaki sayfa adı "VERİ GİRİŞİ" olması gerekiyor. Farklı ise kendinize uyarlarsınız.

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Yol As String, Kayit_Seti As Object
        
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    
    Yol = ThisWorkbook.Path & "\Kapalı_Dosya.xls"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Yol & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Set Kayit_Seti = Baglanti.Execute("Select * From [VERİ GİRİŞİ$D5:D6]")
    Range("D5").CopyFromRecordset Kayit_Seti
    
    Set Kayit_Seti = Baglanti.Execute("Select * From [VERİ GİRİŞİ$E11:L41]")
    Range("E11").CopyFromRecordset Kayit_Seti
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

 

[ormann]

Korhan bey aynı kod ile kapalı dosyayı seçip verileri alabilmek mümkün müdür ?.kodu o şekilde revize eder misiniz ?

 

[ormann]

Korhan bey kapalı dosya adı farklı olabilir.Sayfa adı değişmiyor.Yani "VERİ GİRİŞİ" .Kapalı sayfayı aynı makro ile istediğimiz klasörün içerisinden seçip dosyayı açmadan verileri alabilmeliyiz.Kod bu şekilde olabilir mi?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Baglanti As Object, Dosya As Variant, Kayit_Seti As Object
      
    Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyaları (*.xls*), *.xls*", Title:="Lütfen bir dosya seçiniz...")
  
    If Dosya = False Then
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbExclamation
        Exit Sub
    End If
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Zaman = Timer
  
    Set Baglanti = CreateObject("AdoDb.Connection")
  
    Select Case Val(Application.Version)
        Case Is < 12
            Baglanti.Open "Provider=Microsoft.Jet.OleDb.4.0;Data Source=" & Dosya & ";Extended Properties=""Excel 8.0;HDR=No"""
        Case Is > 11
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya & ";Extended Properties=""Excel 12.0 Xml;Hdr=No"""
    End Select
  
    Set Kayit_Seti = Baglanti.Execute("Select * From [VERİ GİRİŞİ$D4:D5]")
    Range("D4").CopyFromRecordset Kayit_Seti
  
    Set Kayit_Seti = Baglanti.Execute("Select * From [VERİ GİRİŞİ$E11:L41]")
    Range("E11").CopyFromRecordset Kayit_Seti
  
    Range("E11:F41").NumberFormat = "hh:mm;@"
  
    Kayit_Seti.Close
    Baglanti.Close
  
    Set Baglanti = Nothing: Set Kayit_Seti = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Veriler aktarılmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye"
End Sub

 

[ormann]

Korhan bey aşağıdaki makroda hata veriyor
Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""

 

[Korhan Ayhan]

İlk kod çalışmış mıydı?

 

[ormann]

Oda çalışmadı

 

[Korhan Ayhan]

O satırı aşağıdaki gibi değiştirip deneyin.

Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dosya & ";
Extended Properties=""Excel 8.0;HDR=No"""

 

[ormann]

Korhan bey gerçekten kodlar çok şahane çalışıyor.Çok Teşekkür ederim.Ekli linkte harcırah(Mart) içerisindeki Aktar makrosundan Harcırah(Şubat) 'ı seçtğimde veirler geliyor.Fakat E11:F41 hücre aralığına saat formatında gelirse sorun çözülecek.Biçimlendirmeyi saat olarak seçmeme rağmen yine değişiyor.Burasıda olursa sorun kalmayacak.
http://dosya.co/q1no3zhek0qr/HARCIRAH-ŞUBAT.xls.html
http://dosya.co/0edsrt6dfyv5/HARCIRAH_2015-MART.xls.html

 

[Haluk]

Alternatif olarak aşağıdaki kodu da kullanabilirsiniz....

Sub GetData()
    'Haluk - 27/10/2018
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim mySheet As String
    Dim FSO As Object, SourceFolder As Object
    
    Time1 = Now
    Range("D5, D6, E11:L41") = Empty
    mySheet = "VERİ GİRİŞİ"
    myFile = "Kapalı_Dosya.xls"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder(ThisWorkbook.Path)
    
    myStr = "='" & SourceFolder & Application.PathSeparator
    myStr = myStr & "[" & myFile & "]" & mySheet & "'"
    Range("D5:D6").FormulaArray = myStr & "!D5:D6"
    Range("D5:D6") = Range("D5:D6").Value
    Range("E11:L41").FormulaArray = myStr & "!E11:L41"
    Range("E11:L41") = Range("E11:L41").Value
    Range("E11:F41").NumberFormat = ("hh:mm")
    
    Time2 = Now
    timeElapsed = Format(Time2 - Time1, "hh:mm:ss,ms")
    MsgBox "İşlem süresi: " & timeElapsed
    Range("A1").Select
End Sub

.

 

[ormann]

Range("D4:D5").FormulaArray = myStr & "!D4:D5"

Haluk bey çok teşekkür ederim.Şu makroda hata veriyor

 

[Haluk]

Aşağıdaki kodu sizin HARCIRAH-ŞUBAT.xlsx dosyasında denedim, bir problem olmadı ...

Sub GetData()
    'Haluk - 27/10/2018
    Dim Time1 As Date, Time2 As Date
    Dim timeElapsed As String, myFile As String
    Dim mySheet As String
    Dim FSO As Object, SourceFolder As String
    
    Range("D4, D5, E11:L41") = Empty
    mySheet = "VERİ GİRİŞİ"
    
    myFile = Application.GetOpenFilename(FileFilter:="Excel Dosyaları (*.xls*), *.xls*", Title:="Lütfen bir dosya seçiniz...")
    
    Time1 = Now

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set strFile = FSO.Getfile(myFile)
    SourceFolder = FSO.Getfile(myFile).ParentFolder.Path
    
    myStr = "='" & SourceFolder & Application.PathSeparator
    myStr = myStr & "[" & strFile.Name & "]" & mySheet & "'"
    Range("D4:D5").FormulaArray = myStr & "!D4:D5"
    Range("D4:D5") = Range("D4:D5").Value
    Range("E11:L41").FormulaArray = myStr & "!E11:L41"
    Range("E11:L41") = Range("E11:L41").Value
    Range("E11:F41").NumberFormat = "hh:mm"
    Range("D4:D5").NumberFormat = "dd.mm.yyyy"
    
    Time2 = Now
    timeElapsed = Format(Time2 - Time1, "hh:mm:ss,ms")
    MsgBox "İşlem süresi: " & timeElapsed
    Range("A1").Select
End Sub

.

 

[Korhan Ayhan]

#6 nolu mesajımdaki kodu revize ettim. Tekrar deneyiniz.

 

[ormann]

Korhan bey çok teşekkür ederim.Kodlar xls formatında çalışıyor.Fakat *.xls; *.xlsb; *.xlsx; *.xlsm", formtlarında hata veriyor.Bu formatlar dada çalışması için ne yapmamız gerekiyor.?

 

[Korhan Ayhan]

#6 nolu mesajıma küçük bir ekleme yaptım. Deneyip sonucu bildirir misiniz?