Makro ile çok satırlı verileri kopyalama

[gokcesenel]

Merhabalar herkese,

Yaklaşık 1000 satırlık bir veriyi, başka bir sheete her bir satırdan 12'şer satır olacak şekilde kopyalamak istiyorum. Yani aşağıda record ile kaydettiğim 3-5 satırı 1000 satıra kadar olan veri için yaptırmak istiyorum. Yardımcı olabilir misiniz?

Sheets("Sheet1").Select
    Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1:A12").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Range("A2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A13:A24").Select
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A25:A36").Select
    ActiveSheet.Paste

 

[Mustafa MUTLU]

12 satır kopyalıyorsun da
yapıştırırken yine satır atlamıyorsun
12 nin amacını anlamadım..

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin

Sub Kopyala()
    Dim Bak1 As Integer
    Dim Bak2 As Integer
    Dim Sira As Long
    For Bak1 = 1 To 1000
        For Bak2 = 1 To 12
            Sheets("Sayfa2").Cells(Sira + Bak2, 1).Value = Sheets("Sayfa1").Cells(Bak1, 1).Value
        Next
        Sira = Sira + 12
    Next
End Sub

 

[Murat OSMA]

Alternatif..

[SIZE="2"]Sub Emre()
    For i% = 1 To Sayfa1.Cells(Rows.Count, "A").End(3).Row
        son& = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
        Sayfa2.Range("A" & son & ":A" & son + 11) = Sayfa1.Cells(i, 1).Value
    Next i
    i = Empty: son = Empty
End Sub[/SIZE]

 

[gokcesenel]

Çok teşekkür ederim işime yaradı. :dua2:

 

[siberati]

           
           

 

[siberati]

Excelde a14:k14 arası hücrelerdeki verileri, a12:k12 ye otomatik kopyalama yapılacak kod lazım. Ama sadece a14 değil.a15'e girdiğimde de, a16 ya girdiğimde de gibi. Yani aşağıya doğru a hücresine girdiğimde ya da tıkladığımda a12 hücresinin olduğu satıra kopyalanmasını istiyorum.

 

[Korhan Ayhan]

İşlemi yapmak istediğiniz sayfanızın kod bölümüne uygulayıp deneyiniz.

Kod içinde gördüğünüz hücre aralığında çalışır.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A14:K1000")) Is Nothing Then Exit Sub
    Range("A12").Resize(, 11).Value = Cells(Target.Row, 1).Resize(, 11).Value
End Sub

 

[siberati]

İlginize teşekkür ederim. Ancak işe yaramadı.

 

[Korhan Ayhan]

Çalışması için ilgili hücrelerde değişiklik yapmalısınız.

 

[siberati]

Çalışması için ilgili hücrelerde değişiklik yapmalısınız.

Evet şimdi oldu. Çok teşekkür ederim.