Kapalı dosyadan buton ile veri alma.

[Korhan Ayhan]

Kodun aşağıdaki satırı temizleme işlemi yapıyor.

Range("H2:I" & Rows.Count).ClearContents

H2 hücresinden başlıyor I sütunu son satıra kadar temizlene yapıyor.

Aşağıdaki satırda kayıt setini H2 hücresinden itibaren hücreye aktarıyor.

Range("H2").CopyFromRecordset rs

 

[Kullancı0642]

Korhan bey 1 ve 2 aktarma makrolari ile istedigim sekilde aktariyorum burada sorun yok. Ancak aktarma 1 makrosunu tekrar calistırıram makro2 nin bilgilerinide siliyor. Makrolarda silinecek yani H2:I bölgesini H2:I11 olarak kabul etmiyor, bunu nasil cözebiliriz. Tsk ederim.

 

[Korhan Ayhan]

Tasarladığınız kodu ya da örnek dosyalarınızı ekleyip açıklarsanız daha hızlı yanıt alırsınız.

 

[Kullancı0642]

Merhaba arkadaslar... asagıdaki makro sorunsuz calısıyor ancak acılan dosya ac ekranında iptal dedigimizde makro hata veriyor... nereye ekleme yapabiliriz...
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

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

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")
    If dosya = False Then
        MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir.", vbExclamation
        Exit Sub
    End If
    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

 

[Seli]

Herkese merhabalar, bende kapalı ANA-DOSYA.xlsm adında uzantısını bıldıgım bir dosyadan veri almak istiyorum nasıl yapabilirim? şimdiden teşekkür ederim.

 

[antitez21]

Korhan bey merhaba,

Aşağıdaki koda "select" kısmına üçüncü bir başlık eklemek istediğimde hata alıyorum. Sadece 2 sütundaki verileri aktarıyor. Ama üçüncü bir sütun için "Select [Stok Adı],[Temel Mik.],[Tutarı (KDV Dahil)] from...aralıkta bulunan bir başlık daha eklediğimde geçerli bir ad değil hatası alıyorum. Yardımcı olabilirseniz çok memnun olurum.

Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String
Sheets("veri").Range("A2:C" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")

yol = ThisWorkbook.Path
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & yol & "\Temp1.xlsx;extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Stok Adı],[Temel Mik.],[Tutarı (KDV Dahil)] from [Temp1$a1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Sheets("veri").Range("A2").CopyFromRecordset rs
rs.Close: conn.Close

MsgBox "Aktarma yapıldı."
End Sub

 

[Korhan Ayhan]

Sütun başlıklarında kullanılan nokta sorun yaratmaktadır.

Aşağıdaki şekilde bu sorunu aşabilirsiniz.

[Temel Mik#]

 

[antitez21]

Vallahi bilgi güçtür ne diyeyim. Çok teşekkür ederim.