Kritere Göre Sayfalar Arası Aktarım

[akmes]

Merhaba,

Takip ettiğim 40 a yakın mağazam var kopyala yapıştır yaparak verileri aktararak kontrol etmek çok zamanımı alıyor. Ekteki excel dosyamda yapmak istediğim, A sütunundaki isimlerle eşleşen sayfalara Sayfa 1 deki B4 ve F4 başlamak kaydı ile aşağıya doğru sütundaki karşılık gelen değerleri aktarmak. Makro ile bu aktarımı yapabilir miyiz. Yardımlarınızı rica ediyorum.

https://dosyam.org/Au6/Kitap1.xlsm

 

[Haluk]

Sub Test()
'   Haluk - 10/03/2022
    Dim daoDBEngine As Object, DB As Object, RS As Object, i As Integer, myShop As String
    
    Set daoDBEngine = CreateObject("DAO.DBEngine.120")
    Set DB = daoDBEngine.OpenDatabase(ThisWorkbook.FullName, False, False, "Excel 8.0; HDR=No; IMEX=1;")
    
    For i = 2 To Sheets.Count
        myShop = Replace(UCase(Sheets(i).Name), "ı", "I")
        Set RS = DB.OpenRecordset("Select Format(F2,""dd.mm.yyyy""), F6 From [Sayfa1$A4:F] Where F1='" & myShop & "'")
        Sheets(i).Range("E2").CopyFromRecordset RS
    Next
    
    RS.Close
    DB.Close
    Set DB = Nothing
    Set daoDBEngine = Nothing
End Sub

.

 

[akmes]

Sub Test()
'   Haluk - 10/03/2022
    Dim daoDBEngine As Object, DB As Object, RS As Object, i As Integer, myShop As String
   
    Set daoDBEngine = CreateObject("DAO.DBEngine.120")
    Set DB = daoDBEngine.OpenDatabase(ThisWorkbook.FullName, False, False, "Excel 8.0; HDR=No; IMEX=1;")
   
    For i = 2 To Sheets.Count
        myShop = Replace(UCase(Sheets(i).Name), "ı", "I")
        Set RS = DB.OpenRecordset("Select Format(F2,""dd.mm.yyyy""), F6 From [Sayfa1$A4:F] Where F1='" & myShop & "'")
        Sheets(i).Range("E2").CopyFromRecordset RS
    Next
   
    RS.Close
    DB.Close
    Set DB = Nothing
    Set daoDBEngine = Nothing
End Sub

.

Haluk Bey, Elinize emeğinize sağlık çok güzel olmuş, Çok teşekkür ederim.