Buton ile aynı klasördeki farklı excel dosyasından veri alma

[MuhammetSN]

Herkese merhaba, Aynı klasör içinde 2 farklı excel dosyası mevcut, "2021 Hedefimiz" isimli excel dosyasında Sayfa3'te yer alan "Kart Çekimleri" isimli Butona tıkladığımda aynı excelin B7 Hücresine "Kart Çekimi" isimli excel dosyasının B3:G17 Satırlarının gelmesini istiyorum. Yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim iyi günler.

İndir 2021 Hedefimiz

Dosyayı indir 2021 Hedefimiz

dosya.co

İndir Kart Çekimi

Dosyayı indir Kart Çekimi

dosya.co

 

[ÖmerFaruk]

KartCekimi Sayfa1 B3:G17 aralığındaki veriler, 2021 Hedefimiz de hangi sayfaya hangi hücreye gelecek?

 

[MuhammetSN]

KartCekimi Sayfa1 B3:G17 aralığındaki veriler, 2021 Hedefimiz de hangi sayfaya hangi hücreye gelecek?

Butonun olduğu sayfa yani Sayfa3 Ün B7 hücresine gelecek Ömer Faruk Bey

 

[ÖmerFaruk]

Aşağıdaki kodları bir module içine yapıştırın.
Botuna da bu makroyu atayın.

Sub AdoVeriAl()
    Dim Dosya As String, ifade As String, TimerStart As Double
    Dim MyCn   As Object, MyRs As Object
    
    TimerStart = Timer
    Worksheets("Sayfa3").Range("B:J").Clear
 
    Dosya = ThisWorkbook.Path & "\Kart Çekimi.xlsx"
    Set MyCn = CreateObject("ADODB.Connection")
    Set MyRs = CreateObject("adodb.recordset")
    MyCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    MyCn.Properties("Data Source") = Dosya
    MyCn.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    MyCn.Open
    ifade = "select * from [Sayfa1$B3:G17]"
    MyRs.Open ifade, MyCn, 1, 1
    If MyRs.RecordCount > 0 Then
        Sheets("Sayfa3").Range("B7").CopyFromRecordset MyRs
    End If
    MyRs.Close
    MyCn.Close

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - TimerStart, "0.00") & " Saniye", vbInformation
    Set MyCn = Nothing: Set MyRs = Nothing: Dosya = "": ifade = "": Aranan = ""
End Sub

 

[MuhammetSN]

Aşağıdaki kodları bir module içine yapıştırın.
Botuna da bu makroyu atayın.

Sub AdoVeriAl()
    Dim Dosya As String, ifade As String, TimerStart As Double
    Dim MyCn   As Object, MyRs As Object
   
    TimerStart = Timer
    Worksheets("Sayfa3").Range("B:J").Clear

    Dosya = ThisWorkbook.Path & "\Kart Çekimi.xlsx"
    Set MyCn = CreateObject("ADODB.Connection")
    Set MyRs = CreateObject("adodb.recordset")
    MyCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    MyCn.Properties("Data Source") = Dosya
    MyCn.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    MyCn.Open
    ifade = "select * from [Sayfa1$B3:G17]"
    MyRs.Open ifade, MyCn, 1, 1
    If MyRs.RecordCount > 0 Then
        Sheets("Sayfa3").Range("B7").CopyFromRecordset MyRs
    End If
    MyRs.Close
    MyCn.Close

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - TimerStart, "0.00") & " Saniye", vbInformation
    Set MyCn = Nothing: Set MyRs = Nothing: Dosya = "": ifade = "": Aranan = ""
End Sub

Modülden kastınız tam olarak nedir acaba ? Kod yazma konusunda çok yeniyim henüz o kısımları bilmiyorum da

 

[MuhammetSN]

Aşağıdaki kodları bir module içine yapıştırın.
Botuna da bu makroyu atayın.

Sub AdoVeriAl()
    Dim Dosya As String, ifade As String, TimerStart As Double
    Dim MyCn   As Object, MyRs As Object
   
    TimerStart = Timer
    Worksheets("Sayfa3").Range("B:J").Clear

    Dosya = ThisWorkbook.Path & "\Kart Çekimi.xlsx"
    Set MyCn = CreateObject("ADODB.Connection")
    Set MyRs = CreateObject("adodb.recordset")
    MyCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    MyCn.Properties("Data Source") = Dosya
    MyCn.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    MyCn.Open
    ifade = "select * from [Sayfa1$B3:G17]"
    MyRs.Open ifade, MyCn, 1, 1
    If MyRs.RecordCount > 0 Then
        Sheets("Sayfa3").Range("B7").CopyFromRecordset MyRs
    End If
    MyRs.Close
    MyCn.Close

    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - TimerStart, "0.00") & " Saniye", vbInformation
    Set MyCn = Nothing: Set MyRs = Nothing: Dosya = "": ifade = "": Aranan = ""
End Sub

Hocam teşekkür ederim dediğiniz işlemi yaptım ve formül güzel bir şekilde çalıştı, ayrıca Kart çekimi excel sayfasının satır ve sütun genişliklerini de tablo ile birlikte getirebilir miyiz acaba ?

 

[ÖmerFaruk]

Ben bunu ADO ile yaptım.
ADO içinde biçimlendirme imkanı var mı bilemiyorum.

Şöyle bir durum var.
Eğer tablonuzun biçimi, başlıkları, renkler vs hep aynı olacak. Sadece toplam satırı satır sayısına göre değişecek diyorsanız kodlara ilaveten yapılabilir.
Siz istediğiniz formatı eksiksiz olarak ÖRNEK tabloyla verin. Kodlara eklerim

 

[MuhammetSN]

Ben bunu ADO ile yaptım.
ADO içinde biçimlendirme imkanı var mı bilemiyorum.

Şöyle bir durum var.
Eğer tablonuzun biçimi, başlıkları, renkler vs hep aynı olacak. Sadece toplam satırı satır sayısına göre değişecek diyorsanız kodlara ilaveten yapılabilir.
Siz istediğiniz formatı eksiksiz olarak ÖRNEK tabloyla verin. Kodlara eklerim

Tablolarımın hepsi farklı biçimlere sahip hocam o yüzden böyle bir talepte bulundum. Diğer butonlarda aynı excel içinden verileri çekerken aşağıdaki formülü kullanmıştım aynı formülü sizin formülünüz ile birleştirebilir miyim acaba bilginiz var mı ?

For i = 2 To 12
Columns(i).ColumnWidth = Sheets("Sayfa1").Columns(i).ColumnWidth

Next

For j = 7 To 21
Rows(j).RowHeight = Sheets("Sayfa1").Rows(j).RowHeight

Next
End Sub

 

[ÖmerFaruk]

ADO da öyle formül kullaamazsınız.
Her bir buton farklı excel dosyalarından Tablo çekecek gördüğüm kadarıyla.
Siz tüm tablolarınızı benzer bir formata getirin, ben halledeceğim.
Söz.

 

[MuhammetSN]

Teşekkür ederim Ömer Faruk Hocam, düzenleyip sizinle paylaşacağım