Çalışma kitaplarında değerleri güncelleme

[cleanner]

Merhaba Arkadaşlar,

kodları kendime göre uyarlamaya çalıştım ama işin içinden çıkamadım yardım ederseniz mutlu olurum.
sorum ve dosya ektedir.

 

[Murat OSMA]

Şu kodları Modüle yapıştırıp bir deneyiniz;

Sub Kapalıdan_Al_Kapalıya_Ver()
    Dim Con As Object, Rs As Object
    Dim Fso As Object, Klasor As Object, Dosyalar As Object
    Dim Sorgu As String, yol As String, dosya As String
    Dim Sutun As Byte
    Dim Ac As Workbook
    Application.ScreenUpdating = False
    On Error Resume Next
        Set Con = CreateObject("AdoDb.Connection")
        Set Rs = CreateObject("AdoDb.RecordSet")
        Set Fso = CreateObject("Scripting.FileSystemObject")
        yol = ThisWorkbook.Path
        Set Klasor = Fso.getfolder(yol)
     Range("B4:B1000").ClearContents
     For Each Dosyalar In Klasor.Files
        If Dosyalar.Name <> "data.xlsm" Then
            dosya = Replace(Dosyalar.Name, ".xlsx", "")
            Con.Open "Provider=Microsoft.ace.oleDb.12.0;Data Source=" & _
            ThisWorkbook.Path & "\" & dosya & ".xlsx" & _
            ";Extended Properties=""Excel 12.0;HDR=yes"""
            Sorgu = "Select * FROM [Sayfa1$]"
            Rs.Open Sorgu, Con, 1, 1
            Range("B65536").End(3)(2, 1).CopyFromRecordset Rs
            Rs.Close: Con.Close
    ThisWorkbook.Sheets(1).Range("b1").Copy
    Set Ac = Workbooks.Open(Dosyalar): Ac.Activate
    ActiveWorkbook.Sheets(1).Range("E1").PasteSpecial xlPasteValues
    Ac.Close True: Range("E1").ClearContents
    End If
    Next Dosyalar
    Columns.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set Con = Nothing: Set Rs = Nothing: Set Fso = Nothing
    Set Klasor = Nothing: Set Dosyalar = Nothing: Set Ac = Nothing
    yol = vbNullString: dosya = vbNullString
End Sub

 

[cleanner]

Sayın Murat OSMA

Öncelikle hızlı cevabınız için teşekkür ederim, gerçekten tam isabet oldu emeğinize yüreğinize sağlık ...

 

[cleanner]

Sayın Murat OSMA,

Range("B65536").End(3)(2, 1).CopyFromRecordset Rs

bu satırı açıklayabilir misiniz, buradaki(2,1) ne anlama geliyor acaba?

 

[Murat OSMA]

O kadar satırdan neden o kısmı merak ettiniz ?

 

[cleanner]

O kadar satırdan neden o kısmı merak ettiniz ?

sizi tekrar uğraştırmak istemediğim için ben kendime uyarlamaya çalışıyorum, bende datanın tüm dosyalarda D2 hücresine kopyalanması gerekiyor bu yüzden sordum, sizin yaptığınız işlemde A2 hücresine kopyalanıyordu

 

[cleanner]

bu işlemi yapmanın bir yolu var mı arkadaşlar?

 

[Murat OSMA]

Konuyu açan sizsiniz, dosya sizin dosya, araya herhangi bir üye girip mesaj yazmadı. "BEN KENDİME UYARLAMAYA ÇALIŞIYORUM" ne demek ? :dusun: :bad:

Bu mesajınıza yanıt verebilirim sadece;

Sayın Murat OSMA,

Range("B65536").End(3)(2, 1).CopyFromRecordset Rs

bu satırı açıklayabilir misiniz, buradaki(2,1) ne anlama geliyor acaba?

Kayıt setindeki verileri B sütunundaki dolu olan son satırdan itibaren yaz.. demek...


Yardımcı olmak isteyen arkadaşlar olacaktır. İyi günler... k::

 

[cleanner]

Konuyu açan sizsiniz, dosya sizin dosya, araya herhangi bir üye girip mesaj yazmadı. "BEN KENDİME UYARLAMAYA ÇALIŞIYORUM" ne demek ? :dusun: :bad:

Bu mesajınıza yanıt verebilirim sadece;

Kayıt setindeki verileri B sütunundaki dolu olan son satırdan itibaren yaz.. demek...


Yardımcı olmak isteyen arkadaşlar olacaktır. İyi günler... k::

Bilgi için teşekkür ederim. Haklısınız, kendime uyarlamaktan kasdettiğim şey direk hazıra konmamak içindi. Durmadan sormak yerine sizin kodlarınızı asıl olması gereken yerlere ben anlayarak kendim yerleştirmeye çalışacaktım. Fakat beceremedim. Bu durumda sizi daha çok uğraştırmış kusura bakmayın dosyamı tekrar gönderiyorum teşekkür ederim.

 

[cleanner]

güncel................................

 

[Murat OSMA]

Not: Normalde kesinlikle sonradan değişen dosyalarla ilgilenmiyorum.

Kodları bu şekilde revize edip deneyiniz;

Private Sub CommandButton1_Click()
    Dim Con As Object, Rs As Object
    Dim Fso As Object, Klasor As Object, Dosyalar As Object
    Dim Sorgu As String, yol As String, dosya As String
    Dim Sutun As Byte
    Dim Ac As Workbook
    Application.ScreenUpdating = False
    On Error Resume Next
        Set Con = CreateObject("AdoDb.Connection")
        Set Rs = CreateObject("AdoDb.RecordSet")
        Set Fso = CreateObject("Scripting.FileSystemObject")
        yol = ThisWorkbook.Path
        Set Klasor = Fso.getfolder(yol)
     Range("A4:E1000").ClearContents
     For Each Dosyalar In Klasor.Files
        If Dosyalar.Name <> "data.xlsm" Then
            dosya = Replace(Dosyalar.Name, ".xlsx", "")
            Con.Open "Provider=Microsoft.ace.oleDb.12.0;Data Source=" & _
            ThisWorkbook.Path & "\" & dosya & ".xlsx" & _
            ";Extended Properties=""Excel 12.0;HDR=YES"""
            Sorgu = "Select [başlık7] FROM [Sayfa1$]"
            Rs.Open Sorgu, Con, 1, 1
            Range("E65536").End(3)(2, 1).CopyFromRecordset Rs
            Rs.Close: Con.Close
    ThisWorkbook.Sheets(1).Range("C1").Copy
    Set Ac = Workbooks.Open(Dosyalar): Ac.Activate
    ActiveWorkbook.Sheets(1).Range("D2").PasteSpecial xlPasteValues
    Ac.Close True: Range("D2").ClearContents
    ThisWorkbook.Sheets(1).Range("a65536").End(3)(2, 1) = dosya
    End If
    Next Dosyalar
    Columns.AutoFit
    Range("a65536").End(3).ClearContents
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Set Con = Nothing: Set Rs = Nothing: Set Fso = Nothing
    Set Klasor = Nothing: Set Dosyalar = Nothing: Set Ac = Nothing
    yol = vbNullString: dosya = vbNullString
End Sub