Aynı kitap içinde. Sayfadan sayfaya veri aktarımı.

[Ömer]

Eski kodların üzerine ilave yapmışım. Kodlar karıştı

Bu şekilde deneyin.

Sub BulAktar()
 
    Dim Sd As Worksheet, sat As Long, sut As Byte, c As Range, Adr As String
 
    Set Sd = Sheets("Data")
 
    Application.ScreenUpdating = False
    sat = Cells(Rows.Count, "K").End(xlUp).Row + 1
    If Range("K5") = "" Then sat = 5
 
    With Sd.Range("D:F")
        Set c = .Find(Range("C2"), , xlValues, xlWhole)
        If Not c Is Nothing Then
             Adr = c.Address
             Do
                If c.Column <> 5 Then
                    sut = 4
                    If c.Column = 4 Then sut = 6
                    If Sd.Cells(c.Row, "N") = "" And Sd.Cells(c.Row, "H") <> "" Then
                        If Sd.Cells(c.Row, sut) = Range("E2") Then
                           Sd.Range("B" & c.Row, "C" & c.Row).Copy
                           Cells(sat, "H").PasteSpecial Paste:=xlPasteValues
                           Cells(sat, "J") = Sd.Cells(c.Row, "E")
                           Cells(sat, "K") = Sd.Cells(c.Row, "D")
                           Sd.Range("H" & c.Row, "L" & c.Row).Copy
                           Cells(sat, "L").PasteSpecial Paste:=xlPasteValues
                           Cells(sat, "Q") = Sd.Cells(c.Row, "F")
                           Sd.Cells(c.Row, "N") = "Ok"
                           sat = sat + 1
                        End If
                    End If
                End If
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    End With
 
    Range("C2").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
 
End Sub

.

 

[Bora K]

Tekrardan Merhaba;
Ömer Bey ellerinize sağlık. Makromuz gayet güzel oldu.

Lakin şu şekilde bir durum var. Ben kodu başka dosyalarda da kullanacağım.
O dosyalarda ana şablon aynı aktarılacak sütunlar bazı az
bazı çok oluyor yada aralarda boşluk oluyor.
Ben kendim yapmaya çalıştım ama hata verdiyorum koda.

Makronun şu kısmını biraz daha opsiyonel yapabilirmiyiz acaba?

Sd.Range("B" & c.Row, "C" & c.Row).Copy
Cells(sat, "H").PasteSpecial Paste:=xlPasteValues
Cells(sat, "J") = Sd.Cells(c.Row, "E")
Cells(sat, "K") = Sd.Cells(c.Row, "D")
Sd.Range("H" & c.Row, "L" & c.Row).Copy
Cells(sat, "L").PasteSpecial Paste:=xlPasteValues
Cells(sat, "Q") = Sd.Cells(c.Row, "F")

Örneğin burada BC aralığı kopyalanmış H ye yapıştırılıyor oysa
I sütununa veri gitmemesi lazım gibi. Burada Sd.Range ler işi bozuyor.
Bozmuyorda bozuyor işte mazur görün lütfen.
Aktarılacak sütunları ben tek tek ilave edeyim yada çıkartayım istiyorum.
Umarım anlatabildim.

 

[Ömer]

Sd.Range("B" & c.Row, "C" & c.Row).Copy
Cells(sat, "H").PasteSpecial Paste:=xlPasteValues
Cells(sat, "J") = Sd.Cells(c.Row, "E")
Cells(sat, "K") = Sd.Cells(c.Row, "D")
Sd.Range("H" & c.Row, "L" & c.Row).Copy
Cells(sat, "L").PasteSpecial Paste:=xlPasteValues
Cells(sat, "Q") = Sd.Cells(c.Row, "F")

Yukarıdaki satırları silerek,

Cells(sat, "Q") = Sd.Cells(c.Row, "F")

Tek tek bu satır gibi tanım yapabilirsiniz.

Bu satır. Kodun çalıştığı Q sütununa, data sayfasındaki F sütunundaki değeri yazar.Bu mantıkla tüm aktarımları tek tek yazabilirsiniz.

.

 

[Bora K]

Çok teşekkür ederim Ömer Hocam.
Ellerinize sağlık.

Herşey gönlünüzce olsun inşallah.
Saygılarımla.

 

[Ömer]

Rica ederim, iyi çalışmalar.
Saygılar.