• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kapalı dosyadan buton ile veri alma.

S

schlecht

Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
İyi akşamlar. Ekte bununan;
Kapalı.xlsx dosyasnındaki A sütununu, Açık.xlsm dosyasındaki H sütununa,
Kapalı.xlsx dosyasnındaki F sütununu, Açık.xlsm dosyasındaki I sütununa,
buton yardımı ile kopyalmak istiyorum. Dosyalar aynı dizinde değil ve kapalı.xlsx dosya ismi değişken fakat sütunlar sabit, veriler yukarıdaki gibi. Forumda araştırma yaptım fakat uygun örnek bulamadım.

Yardımlarınızı rica ediyorum,

Teşekkürler.
 

Ekli dosyalar

İyi akşamlar yardımcı olabilecek biri var mı acaba, elinde örnek olan?

Teşekkürler.
 
Açık dosyanızın bulunduğu yeri kodlardaki yol değişkenine yazınız.
Dosyanız ektedir.

DOSYAYI INDIR

Kod: 
Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String
Range("H2:I" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
'Yol yerine kendi yolunuzu giriniz.
yol = ThisWorkbook.Path
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & "\Kapalı.xlsx;extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Başlık 1],[Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("H2").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox "Aktarma yapıldı."
End Sub
 

Ekli dosyalar

Hocam cevabınız için teşekkür ederim. Fakat sorumda da belirttiğim gibi "Dosyalar aynı dizinde değil ve kapalı.xlsx dosya ismi değişken " kapalı olacak dosyayı seçmem gerekiyor. Formülü bu şekilde düzenlemek mümkün mü?
 
Kodları aşağıdaki ile değiştiriniz.:cool:

Kod: 
Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String, dosya
Range("H2:I" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename("Excel Dosyaları,xlsx", , "LÜTFEN DOSYAYI SEÇİNİZ")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Başlık 1],[Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("H2").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox "Aktarma yapıldı."
End Sub
 
Hocam çok teşekkür ederim. Tam istediğim gibi çalıştı. Çok işime yaradı inanın.
 
BAZI HÜCREDEKİ VERİLER AKTARILMIYOR. AYNI SÜTUNDAKİ BAZI HÜCRELER GELİYOR AMA BAZI HÜCRELER DİĞER EXCELE AKTARILMIYOR. HÜCRE BİÇİMİYLE ALAKASI VAR MIDIR?
 
Lütfen bağırmayınız ve forum kurallarını okuyunuz.
 
Orion1' Alıntı:
Kodları aşağıdaki ile değiştiriniz.:cool:

Kod: 
Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String, dosya
Range("H2:I" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename("Excel Dosyaları,xlsx", , "LÜTFEN DOSYAYI SEÇİNİZ")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Başlık 1],[Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("H2").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox "Aktarma yapıldı."
End Sub
Genişletmek için tıkla ...
Hocam çok güzel bir çalışma, emeğinize sağlık. Kullanmak istersek. Alacağı ve kopyalayacağı sütunları nasıl değiştirebiliriz. Mesela A'ya getirdim ama mutlaka B'ye geliyor. O değişkenler nelerdir. Mesela C F'ye D L'ye gelsin dersek.
Saygılarımla
 
Sorgu satırını düzenlemek gerekir. Bunun içinde tablonuzu görmek gerekir.
 
Korhan Ayhan' Alıntı:
Sorgu satırını düzenlemek gerekir. Bunun içinde tablonuzu görmek gerekir.
Genişletmek için tıkla ...

Hocam, öğrenmek en iyisi. Sizler sayesinde her gün bir şeyler daha öğrenmeye çalışıyoruz. Dosya görmek demişsiniz. Ben arkadaşın dosyasını kopyaladım, sadece sütun değiştirdim. @Orion1 hocamın yazdığı kod benim dosyalarım için nasıl uyarlanır. Bir kere görsem değişkenleri.
Saygılarımla.
 

Ekli dosyalar

ADO ile işlem yapacaksanız veri tabanı kurallarına uymanız gerekiyor. yoksa sorunlar yaşamanız muhtemeldir.

Deneyiniz.

C++: 
Option Explicit

Sub Düğme1_Tıklat()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    Dim Yol As String, Dosya As String, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
    
    Range("E2:E" & Rows.Count).ClearContents
    Range("G2:G" & Rows.Count).ClearContents
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya = Yol & "Kapalı - Kopya.xlsx"
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sorgu = "Select [Başlık 1], '', [Başlık 2] From [Sayfa1$]"
    
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then Range("E2").CopyFromRecordset Kayit_Seti
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
ADO ile işlem yapacaksanız veri tabanı kurallarına uymanız gerekiyor. yoksa sorunlar yaşamanız muhtemeldir.

Deneyiniz.

C++: 
Option Explicit

Sub Düğme1_Tıklat()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String
    Dim Yol As String, Dosya As String, Zaman As Double
   
    Zaman = Timer
   
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
   
    Range("E2:E" & Rows.Count).ClearContents
    Range("G2:G" & Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Dosya = Yol & "Kapalı - Kopya.xlsx"
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    Sorgu = "Select [Başlık 1], '', [Başlık 2] From [Sayfa1$]"
   
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
   
    If Kayit_Seti.RecordCount > 0 Then Range("E2").CopyFromRecordset Kayit_Seti
   
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
   
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
   
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...

Teşekkür ederim hocam.
 
Orion1' Alıntı:
Kodları aşağıdaki ile değiştiriniz.:cool:

Kod: 
Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String, dosya
Range("H2:I" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename("Excel Dosyaları,xlsx", , "LÜTFEN DOSYAYI SEÇİNİZ")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Başlık 1],[Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("H2").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox "Aktarma yapıldı."
End Sub
Genişletmek için tıkla ...

Hocam, öncelikle tekrar emeğinize sağlık. Şimdi kodda ("H2") yazan yer. H sütünü ve hemen yanına atıyor. H'yi A yapsam A ve hemen yanına B'ye atıyor. Peki A ve C sütununa atmasını istesem ("H") yerine ne yazmam lazım.
 

Ekli dosyalar

  • Ekran Alıntısı.PNG
    Ekran Alıntısı.PNG
    17.9 KB · Görüntüleme: 18
ADO veritabanı uygulamalarında kullanılan bir yapıdır.

Boş satırların, boş sütunların, birleştirilmiş hücrelerin olduğu tablolarda kullanılabiliyor fakat sıkıntı çıkabiliyor.

Evren beyin önerdiği koddaki sorguyu iki kez çalıştırıp gelen kayıt setlerini istediğiniz hücreye aktarabilirsiniz.

Örnek;

C++: 
rs.Open "Select [Başlık 1] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("A2").CopyFromRecordset rs
rs.Close
rs.Open "Select [Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("C2").CopyFromRecordset rs
rs.Close: conn.Close
 
Korhan Ayhan' Alıntı:
ADO veritabanı uygulamalarında kullanılan bir yapıdır.

Boş satırların, boş sütunların, birleştirilmiş hücrelerin olduğu tablolarda kullanılabiliyor fakat sıkıntı çıkabiliyor.

Evren beyin önerdiği koddaki sorguyu iki kez çalıştırıp gelen kayıt setlerini istediğiniz hücreye aktarabilirsiniz.

Örnek;

C++: 
rs.Open "Select [Başlık 1] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("A2").CopyFromRecordset rs
rs.Close
rs.Open "Select [Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("C2").CopyFromRecordset rs
rs.Close: conn.Close
Genişletmek için tıkla ...
Çok teşekkür ederim hocam. Varolun. Sayenizde hep bir adım daha ileri gidiyoruz.
Saygılarımla.
 
Değerli üstatlar ve excel severler.
Bu konu ile alakalı bende bir destek rica ediyorum.
Elimde AYLIK MESAİ TALEP FORMU.XLSX dosyam var.
Bir de ayın günleri ile başlayan günlük dosyalarım var.
Yapmak istediğim,
AYLIK MESAİ TALEP FORMU 'nun içinde, "İÇERİ AKTAR..!" butonuna tıklayarak, kapalı olan dosyalardan dataları çektirip bu aylık dosyanın içerisine toplamak.
Not: Tüm bu dosyalar, tek bir klasörün içerisinde bulunmaktadırlar..
Şimdiden teşekkür eder, hayırlı bayramlar dilerim.
[URL=https://dosya.co/ho3zrh0r0s9t/01.05.21_MESAİ_LİSTESİ_TALEP_FORMU.XLSX.html]01.05.21 MESAİ LİSTESİ TALEP FORMU.XLSX - 17 KB 02.05.21 MESAİ LİSTESİ TALEP FORMU.XLSX - 17 KB AYLIK MESAİ TALEP FORMU.XLSX - 21 KB[/URL]
 

Ekli dosyalar

Birleştirme işlemi yapılacak dosyada 100 satırlık bir tablo oluşturmuşsunuz. Aktarılacak veriler bu 100 satırı geçme ihtimali var mı?

Varsa tablonuzun altındaki unvan bölümü silinecektir.
 
Ben dosyanızı 2500 satırlık olacak şekilde düzenledim.

Sanırım bu haliyle yeterli olacaktır.

İşlem sonunda boş satırlar otomatik gizlenmektedir.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst