dosyadan dosyaya veri çekme

[incsoft]

Arkadaşlar elimde sürekli değişkenlik göstermekte olan export.xlsx adı altında bir dosyam var ve bu dosyanın Sheet1 sayfasının =A:R aralığını kopyalayarak KONTROL2018.xlsx dosyamdaki DATA kısmında bulunan aynı =A:R alanına yapıştırmak istiyorum. Bunu her zaman sürekli elle kopyala yapıştır aracılığıyla yapıyorum kendim basit bir komut kaydı yaparak aktardım ama karışıyor. Bunu bir buton aracılığıyla nasıl yaptırabilirim? Meslea KONTROL2018.xlsx dosyama 1 buton koyacam verileri al dediğimde export.xlsx dosyam açık ya da kapalı farketmez otomatik olarak verileri oraya aktaracak. Siz uzman arkadaşlarımın bilgilerine ihtiyacım vardır.

Teşekkürler..

 

[Hakan ERDOST]

Dosyanız ekte , kendinize uyarlarsınız.

 

[incsoft]

Dosyanız ekte , kendinize uyarlarsınız.

Sub aktar()
Dim Con As Object, Rs As Object, Sorgu As String
Set Con = CreateObject("Adodb.Connection")
Set Rs = CreateObject("Adodb.RecordSet")
Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\export.XLSX" & ";extended properties=""excel 12.0;hdr=no"""
Sorgu = "Select * from [Sheet1$a1:R2000]"
Rs.Open Sorgu, Con, 1, 1
Sheets("Data1").Range("a1").CopyFromRecordset Rs
Rs.Close: Con.Close
End Sub



Private Sub CommandButton1_Click()
Call aktar
End Sub



Neden böyle hata veriyor hocam?

 

[Hakan ERDOST]

Ofis sürümünüz nedir? Excel kaç sürümü kullanıyorsunuz?


Tapatalk kullanarak iPhone aracılığıyla gönderildi

 

[incsoft]

Ofis 2016

 

[Hakan ERDOST]

Ben de herhangi bir hata vermedi. Kodda bir değişiklik yaptınız mı?


Tapatalk kullanarak iPhone aracılığıyla gönderildi

 

[incsoft]

Ben de herhangi bir hata vermedi. Kodda bir değişiklik yaptınız mı?


Tapatalk kullanarak iPhone aracılığıyla gönderildi

sizin dosya da çalışıyor hocam ama kendime uyarlayınca neden hata veriyor anlamadım. İnceliyorum

 

[incsoft]

Ben de herhangi bir hata vermedi. Kodda bir değişiklik yaptınız mı?


Tapatalk kullanarak iPhone aracılığıyla gönderildi

Hocam mümkünse dosyamı incelebilirmisiniz? Dosyam masaüstünde bulunan export.XLSX dosyasından alıyor. Sizinkiler sorunsuz çalışıyor

Teşekkürler.

 

[Hakan ERDOST]

Dışarıdayım şu an, bilgisayara geçince bakarım


Tapatalk kullanarak iPhone aracılığıyla gönderildi

 

[Hakan ERDOST]

Hocam mümkünse dosyamı incelebilirmisiniz? Dosyam masaüstünde bulunan export.XLSX dosyasından alıyor. Sizinkiler sorunsuz çalışıyor

Teşekkürler.

Dosyanızın son hali ekte, inceleyiniz. Aralık tanımlamada hata yapmışsınız.

Sütun başlıklarının üzerine yazılmasını istemiyorsanız kodun Data sayfası ile ilgili böülmdeki A1 'i A2 yapabilirsiniz.

 

[incsoft]

Dosyanızın son hali ekte, inceleyiniz. Aralık tanımlamada hata yapmışsınız.

Sütun başlıklarının üzerine yazılmasını istemiyorsanız kodun Data sayfası ile ilgili böülmdeki A1 'i A2 yapabilirsiniz.

çok teşekkürler hocam

 

[Hakan ERDOST]

Rica ederim. İyi akşamlar.

 

[incsoft]

Rica ederim. İyi akşamlar.

Valla hocam bu sorun kafayı yedirecek anlamadım gittim evimde çalışıp işyerimde çalışmaması. Bu hata neden acaba

 

[Hakan ERDOST]

Kodlar yenilendi. Deneyiniz.

 

[incsoft]

Kodlar yenilendi. Deneyiniz.

Verileri hep bir öncekinin altına atıyor hocam bu sebepten dolayı aşağıdaki gibi bir kod ekledim ancak sanki biraz yavaşlattı buda.. Her butona tıklantığında bir önceki verilerin tamamen revize edilmesi gerekiyor alt alta eklenmemesi gerekiyor. Bu mantık doğrumu yoksa başka ne yapılabilir? Çok teşekkür ederim...

Columns("A:R").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-6
Range("A1").Select

 

[Hakan ERDOST]

Kodu aşağıdaki şekilde değiştirin.

Private Sub CommandButton1_Click()
Dim conn As Object, rs As Object
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\export.xlsx;extended properties=""excel 12.0;hdr=no;imex1"""
rs.Open "select * from [Sheet1$];", conn, 1, 3
Application.ScreenUpdating = False
If rs.RecordCount > 0 Then Range("A1").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close
conn.Close
Set rs = Nothing:  Set conn = Nothing
MsgBox "Veriler aktarıldı."
End Sub

 

[incsoft]

Dim conn As Object, rs As Object Set conn = CreateObject("adodb.connection") Set rs = CreateObject("adodb.recordset") conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _ ThisWorkbook.Path & "\export.xlsx;extended properties=""excel 12.0;hdr=no;imex1""" rs.Open "select * from [Sheet1$];", conn, 1, 3 Application.ScreenUpdating = False If rs.RecordCount > 0 Then Range("A1").CopyFromRecordset rs Application.ScreenUpdating = True rs.Close conn.Close Set rs = Nothing: Set conn = Nothing MsgBox "Veriler aktarıldı."

Çok teşekkürler.. Sizler nasıl hemen kodları geliştirmektesiniz hocam ben bir türlü çözemiyorum..

 

[incsoft]

Kodu aşağıdaki şekilde değiştirin.

Private Sub CommandButton1_Click()
Dim conn As Object, rs As Object
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\export.xlsx;extended properties=""excel 12.0;hdr=no;imex1"""
rs.Open "select * from [Sheet1$];", conn, 1, 3
Application.ScreenUpdating = False
If rs.RecordCount > 0 Then Range("A1").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close
conn.Close
Set rs = Nothing:  Set conn = Nothing
MsgBox "Veriler aktarıldı."
End Sub

Hocam bu hatayı veriyor bunu da dosya ağda çalıştığından dolayı veriyor. Bu dosyayı ortak olarak kullanmaktayız. Ağ bilgisayarında nasıl kullanabiliriz? Yerel bilgisayarımda kullandımı bir sorun yok...

 

[incsoft]

Birde hocam mesela P sütunumun içeriği 11:20:32 şeklindedir bunu birebir değilde 00.01.1900 11:20:32 şeklinde atmaktadır. Bu şekilde birebir sayfa yapısını da bozmadan aktarma yapabilirmiyiz?

 

[Hakan ERDOST]

Private Sub CommandButton1_Click()
 Set Con = CreateObject("Adodb.connection")
    Set rs = CreateObject("Adodb.recordset")
    'yol = "\\denemeserver\denemedosya\"
     yol = "C:\Desktop\"
    Con.Open "provider=microsoft.ACE.oledb.12.0;data source=" & yol & "export.xlsx" & _
     ";extended properties=""Excel 8.0;hdr=yes"""
    Sorgu = "SELECT * FROM [Sheet1$]"
    rs.Open Sorgu, Con, 1, 1
    Range("a2").CopyFromRecordset rs
    rs.Close: Con.Close
    Set Con = Nothing: Set rs = Nothing
End Sub

Kodda bulunan yolu değiştirerek deneyiniz. Tek tırnak yolu kendi server adresine göre düzenleyebilirisiniz.