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

Güngör_ · 25 Mayıs 2024

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 · 25 Mayıs 2024

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

Kod:

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 · 25 Mayıs 2024

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

haliliyas · 25 Mayıs 2024

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

haliliyas · 25 Mayıs 2024

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

Kod:

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 · 25 Mayıs 2024

Merhaba Arkadaşlar,

Kod:

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_ · 25 Mayıs 2024

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 · 25 Mayıs 2024

rica ederim)
iyi çalışmalar

Tevfik_Kursun · 25 Mayıs 2024

Rica ederim,
iyi çalışmalar

hafasepa · Pazartesi saat 18:45'de

hocalarım merhaba, ufak değişiklikler ile kendime uyarlamaya çalıştım. daha sonra yolu değiştireceğim fakat masaüstüne dosya1.xlsm ve dosya2.xlsm adında iki excel dosyası açtım. dosya2 kapalı iken dosya1'den veri yazdıracağım. Her iki çalışma kitabında da çalışma sayfalarının adı "Sayfa1".

Kod:

rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic

adımında aşağıdaki hatayı almaktayım.

"Run-time error - 2147467259 (80004005)
Bu tablo bu elektronik tabloda tanımlı hücre aralıklarının dışında olan hücreler içeriyor."

biraz araştırıp referansları da güncelledim

Microsoft DAO 3.6 Object Library
Microsoft ActiveX Data Objects 2.5 Library

bunları ekledim. Fakat;

Microsoft ADO Ext. 2.5 for DDL and Security olanı bulamadım.. onun yerine Microsoft ADO Ext. 2.8 for DDL and Security olanı seçtim.
Sorunun kaynağı ne olabilir acaba, yanlış uyarlama mı yaptım anlayamadım.

Kod:

Sub VeriGuncelle()

    Dim baglanti As New ADODB.Connection
    Dim rsK As New ADODB.Recordset
        yol = ThisWorkbook.Path & "\dosya2.xlsm"

        baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        yol & ";extended properties=""Excel 12.0;hdr=no"""
        sorgu = "select * from [Sayfa1$A2:D2]"
        rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic
        Set syf = ThisWorkbook.Worksheets("Sayfa1")
        dz = syf.Range("A2:D2").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

haliliyas · Pazartesi saat 20:14'de

~~Microsoft DAO 3.6 Object Library~~ <--- bu satırı silin
~~Microsoft ADO Ext. 2.8 for DDL and Security~~ <--- bu satırı da silin
Microsoft ActiveX Data Objects 2.5 Library <--- sadece bu referansı eklemeniz yeterli DAO olanı da eklerseniz bazen sorun çıkartabiliyor

ama yada sorun [Sayfa1$A2

2] tanımından kaynaklanıyor olabilir burada sadece tek satır tanımlanmış yani tüm veriler tek satırlık 4 hücredeymiş gibi bir tablo [Sayfa1$A2

] gibi son satır tanımlamadan deneyebilir misiniz?
yeni bir konu açıp harici bir siteye dosyanızı yüklerseniz kodları inceleyip yardımcı olmaya çalışırız.

hafasepa · Salı saat 08:58'de

haliliyas' Alıntı:
~~Microsoft DAO 3.6 Object Library~~ <--- bu satırı silin
~~Microsoft ADO Ext. 2.8 for DDL and Security~~ <--- bu satırı da silin
Microsoft ActiveX Data Objects 2.5 Library <--- sadece bu referansı eklemeniz yeterli DAO olanı da eklerseniz bazen sorun çıkartabiliyor

ama yada sorun [Sayfa1$A22] tanımından kaynaklanıyor olabilir burada sadece tek satır tanımlanmış yani tüm veriler tek satırlık 4 hücredeymiş gibi bir tablo [Sayfa1$A2] gibi son satır tanımlamadan deneyebilir misiniz?
yeni bir konu açıp harici bir siteye dosyanızı yüklerseniz kodları inceleyip yardımcı olmaya çalışırız.

Tekrardan merhaba, referansları denedim olmadı. aynı şekilde [A2 : D] olarak ayarladım ki zaten sonradan buna çevirecektim. dosyalar aşağıdaki linkte mevcuttur. iki dosyayı da masaüstümdeyken denemelerimi yaptım.

Özetle dosya1.xlsm üzerinde yapılan değişiklikleri dosya2.xlsm içinde aynı çalışma sayfası, aynı satır / sütunlara dosyayı açmadan yansıtmak istiyorum.

İndir dosyalar rar

Dosyayı indir dosyalar rar

dosya.co

şu da uyarlamaya çalıştığım video, 90 saniye

İndir recording 2025 mp4

Dosyayı indir recording 2025 mp4

dosya.co

haliliyas · Salı saat 12:00'de

yapmak istediğiniz şeyi şimdi anladım ama biraz sorunlu bir istek
mesela rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic satırında hata vermesi doğal, çünkü sayfada hiç veri yok mesela A1

yaparsanız ilk satırda başlık olduğundan bu sefer hata vermez ama olmayan kayıt varmış gibi görünür.
eğer kapalı dosyada kayıt yoksa önce o kaydın eklenmesi gerekiyor.
yani önce kapalı dosyada kaç satır var o kontrol edilecek sonra kayıt sayısı az ise o kadar yeni kayıt eklenecek sonra da sizin diziden veri alarak güncellenmesi sağlanacak, eğer fazlaysa güncelleme sonrası ilgili satırların boş karakterle doldurulması gerekecek.
bunun yerine kitap kapanırken yada istediğiniz zaman bir düğmeye basarak dosya adına tarih ekleyerek yedeklenmesi sağlanabilir. bence daha pratik olur.

hafasepa · Salı saat 15:46'de

haliliyas' Alıntı:
yapmak istediğiniz şeyi şimdi anladım ama biraz sorunlu bir istek
mesela rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic satırında hata vermesi doğal, çünkü sayfada hiç veri yok mesela A1 yaparsanız ilk satırda başlık olduğundan bu sefer hata vermez ama olmayan kayıt varmış gibi görünür.
eğer kapalı dosyada kayıt yoksa önce o kaydın eklenmesi gerekiyor.
yani önce kapalı dosyada kaç satır var o kontrol edilecek sonra kayıt sayısı az ise o kadar yeni kayıt eklenecek sonra da sizin diziden veri alarak güncellenmesi sağlanacak, eğer fazlaysa güncelleme sonrası ilgili satırların boş karakterle doldurulması gerekecek.
bunun yerine kitap kapanırken yada istediğiniz zaman bir düğmeye basarak dosya adına tarih ekleyerek yedeklenmesi sağlanabilir. bence daha pratik olur.

merhaba tekrardan,

yönlendirmeniz sonrası aşağıdaki gibi uyarlayarak çözümü elde ettim. Çok teşekkür ederim. başta çektiğim verinin satır sayısını bularak entegre ettim. kayıt sayısı değişmediğinde sorunumu çözecektir. şuan ki projemde zaten kayıt sayısında azalma/artma olmayacaktı. sadece değerler değişecek. Eğer satır sayısı azalacaksa ne yapılması gerektiğini de anladım. Fakat satır sayısı artsaydı ne yapılabilir merak ediyorum doğrusu. çünkü çalışma kitabını açmadan veri yazdırmak çok güzel.

yine de ek olarak paylaşmak istedim belki bir şey görürsünüz diye.

Kod:

Sub VeriGuncelle()
Dim dosya As String
Dim sonsatir As Variant

sonsatir = Sheets("Sayfa1").Range("A100000").End(xlUp).Row

yol = ThisWorkbook.Path & "\dosya2.xlsm"


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 [Sayfa1$A2:D" & sonsatir & "]"
rsK.Open sorgu, baglanti, adOpenKeyset, adLockPessimistic

Set syf = ThisWorkbook.Worksheets("Sayfa1")
dz = syf.Range("A2:D" & sonsatir).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

İndir dosyalar rar

Dosyayı indir dosyalar rar

dosya.co

haliliyas · Salı saat 16:30'de

kapalı dosyadaki satır sayısı az, açık kitapta çok ise fark kadar kayıt eklemek için

Kod:

rsK.AddNew
    For x = 1 To rs1.Fields.Count - 1
        rsK(x) = dz(y)
    Next x
rsK.Update

benzeri bir kod kulanılabilir

hafasepa · Dün 00:59 da

haliliyas' Alıntı:
kapalı dosyadaki satır sayısı az, açık kitapta çok ise fark kadar kayıt eklemek için

Kod:

rsK.AddNew For x = 1 To rs1.Fields.Count - 1 rsK(x) = dz(y) Next x rsK.Update

benzeri bir kod kulanılabilir

çok teşekkür ederim hocam bunu denemek istiyorum başarabilirsem bana çok lazım olur. Emeğinize sağlık.

haliliyas · Dün 12:56 da

Rica ederim
İyi çalışmalar.

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

Ekli dosyalar