Kapalı çalışma kitabından veri çekme ve veri aktarma...

[Güngör_]

Herkese merhaba,

Excel Makro-VBA kodlamada çok yeniyim, bi konuda yardımınıza ihtiyaçım var. Açık olan AnaDosya ya, kapalı çalışma kitabın dan veri çekme (bu kısmı halletim) ve AnaDosya dan kapalı çalışma kitabına veri kaydetmek istiyorum.

Makro içeren AnaDosya çalışma kitabında Getir ve Kayıt diye iki butonum var (şekil ekle ile yapılmış butonlar). Getir butonu ile AnaDosya ile aynı dizinde bulunan, Kişiler klasöründeki .xlsx çalışma kitaplarından ADO ile veri çekiyorum . Çektiğim veri tüm çalışma kitaplarında aynı aralıkta (Kişi-D4:J23) ve AnaDosyada da aynı aralığa (AnaSayfa-D4:J23) gelmekte. Hangi çalışma kitabından veri çekeçeğimide AnaDosya da "B1", hücresinden seçmekteyim.

Kişiler klasöründen, AnaDosyaya çektiğim veride değişklik/çıkarma veya ekleme yaptıktan sonra Kaydet butonuna bastıktan sonra ilgili aralığın komplesini (D4:J23), eski verileri silerek AnaSayfa-B1 hüçresinde seçtiğim kapalı .xlsx çalışma kitabına aktarsın istiyorum ama yapamadım. Bu konuda yardımlarınızı riva ederim.

İlgili Makro kodum ve örnek çalışmam;
_____________________________________________________________________
Sub RectangleDiagonalCornersRounded1_Click()
Dim dosya As String

yol = ThisWorkbook.Path & "\Kişiler\" & Worksheets("AnaSayfa").Range("B1") & ".xlsx"

dosya = VBA.FileSystem.Dir(yol)

If dosya = vbNullString Then

MsgBox Prompt:="Seçilen Kişi Dosyası Yok", _
Buttons:=vbCritical, _
Title:="KİŞİ YOK"

Range("D4:J23").ClearContents

Else

Dim baglanti As New ADODB.Connection
Dim rs As New ADODB.Recordset

baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from [Kişi$D4:J23]"
rs.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic

With Worksheets("AnaSayfa")
.Range("D4").CopyFromRecordset rs
End With
End If
End Sub
_____________________________________________________________________

 

[haliliyas]

dosyanızı harici bir siteye yüklemeniz mümkün mü?
ama kabaca şunu önerebilirim
kaynak sayfadaki verileri diziye aktarıp, yada doğrudan range ile
oluşturduğunuz recordseti onunla güncelleyebilirsiniz

Sub VeriGuncelle()
Dim dosya As String

yol = ThisWorkbook.Path & "\Kişiler\" & Worksheets("AnaSayfa").Range("B1") & ".xlsx"


Dim baglanti As New ADODB.Connection
Dim rsK As New ADODB.Recordset

baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from [Kişi$D4:J23]"
rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic


Set syf = ThisWorkbook.Worksheets("Kaynak")
dz = syf.Range("D4:J23").Value2
 If Not rsK.EOF And Not rsK.BOF = True Then
 rsK.MoveFirst
 
 For xStr = 1 To UBound(dz)
    rsK(0) = dz(xStr, 1)
    rsK(1) = dz(xStr, 2)
    rsK(2) = dz(xStr, 3)
    'geriye kalanlar
 rsK.MoveNext
 Next xStr
 End If

End Sub

 

[Tevfik_Kursun]

Yardımcı olayım
Ornek_Dosya
iyi çalışmalar

 

[haliliyas]

Teşekkürler sayın @Tevfik_Kursun uygun zamanda dosyayı inceleyeceğim

 

[haliliyas]

aşağıdaki kodu dener misiniz?
Not: tür uyumuyla ilgili kontroller yapılmamıştır ( sayısal alana metin eklemek gibi)

Sub VeriGuncelle()
Dim dosya As String

yol = ThisWorkbook.Path & "\Kişiler\" & Worksheets("AnaSayfa").Range("B1") & ".xlsx"

dosya = VBA.FileSystem.Dir(yol)

If dosya = vbNullString Then

MsgBox Prompt:="Seçilen Kişi Dosyası Yok", _
Buttons:=vbCritical, _
Title:="KİŞİ YOK"
Range("D4:J23").ClearContents
Exit Sub
End If

Dim baglanti As New ADODB.Connection
Dim rsK As New ADODB.Recordset

baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from [Kişi$D4:J23]"
rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic

Set syf = ThisWorkbook.Worksheets("AnaSayfa")
dz = syf.Range("D4:J23").Value2
If Not rsK.EOF And Not rsK.BOF = True Then
rsK.MoveFirst

For xStr = 1 To UBound(dz)
        For yStn = 0 To rsK.Fields.Count - 1
           rsK(yStn) = dz(xStr, yStn + 1)
        Next yStn
rsK.MoveNext
Next xStr
End If
End Sub

 

[Tevfik_Kursun]

Merhaba Arkadaşlar,

Sub VeriGuncelle()
    Dim dosya As String
    Dim baglanti As New ADODB.Connection
    Dim rsK As New ADODB.Recordset
        yol = ThisWorkbook.Path & "\Kişiler\" & Range("B1") & ".xlsx"
        dosya = VBA.FileSystem.Dir(yol)
            If dosya = vbNullString Then
                MsgBox Prompt:="Seçilen Kişi Dosyası Yok", _
                Buttons:=vbCritical, _
                    Title:="KİŞİ YOK"
                Range("D4:J23").ClearContents
                Exit Sub
            End If
        baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        yol & ";extended properties=""Excel 12.0;hdr=no"""
        sorgu = "select * from [Kişi$D4:J23]"
        rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic
        Set syf = ThisWorkbook.Worksheets("AnaSayfa")
        dz = syf.Range("D4:J23").Value2
            If Not rsK.EOF And Not rsK.BOF = True Then
                rsK.MoveFirst
                    For xStr = 1 To UBound(dz)
                        For yStn = 0 To rsK.Fields.Count - 1
                            rsK(yStn) = dz(xStr, yStn + 1)
                        Next yStn
                        rsK.MoveNext
                    Next xStr
            End If
End Sub

Bu hali ile hatasız çalışıyor.
İyi çalışmalar

 

[Güngör_]

Tevfik_Kursun ve haliliyas ilginiz ve cevaplarınız için çok teşekkür edrim. Makro sorunsuz çalışıyor ve isteğimi tam anlamıyla karşıladı.

 

[haliliyas]

rica ederim)
iyi çalışmalar

 

[Tevfik_Kursun]

Rica ederim,
iyi çalışmalar