Her satırı kendisiyle birlikte altına 3 adet daha kopyalanması.

[uygurmuhasebe]

Merhabalar. Sorunum şöyle elimde 1192 satırlık bir veri tablosu var. Bu 1192 satırlık verinin her satırın kendi altına 3 adet daha kopyasını yapmam lazım. şöyle anlatıyım

1 - a
2 - b
3 - c Verim bu şekilde.
4 - d
5 - e


1 - a
2 - a
3 - a
4 - a
5 - b Her satırdan 4 adet gerekiyo.
6 - b
7 - b
8 - b
9 - c

1192 satırı tek tek yapmak oldukça zaman alır. Yardımlarınız için şimdiden teşekkür ediyorum.

 

[Ömer BARAN]

Merhaba.

Verinin alınacağı sayfanın adı Sayfa1, yazılacağı sayfanın adı Sayfa2,
her iki sayfada ilk satırın da BAŞLIK satırı olduğunu (yoksa başlık yazın) düşünürsek;
aşağıdaki kod'u boş bir MODÜL'e yapıştırın ve çalıştırın.
(belgeniz açıkken ALT+F11 tuşlarına bastığınızda açılan VBA ekranında,
üst taraftaki menü çubuğunda INSERT'in altında MODULEye tıklayın ve sağa taraftaki boş alana yapıştırın)

[B]Sub DÖRTLE()[/B]
Dim s1, s2 As Worksheet
Set s1 = Sheets("[B][COLOR="Blue"]Sayfa1[/COLOR][/B]"): Set s2 = Sheets("[B][COLOR="Red"]Sayfa2[/COLOR][/B]")
For brn = [B][COLOR="darkorange"]2[/COLOR][/B] To s1.[A65536].End(3).Row
    ilk = s2.[A65536].End(3).Row + 1
    s2.Cells(ilk, "A") = s1.Cells(brn, "A")
    s2.Cells(ilk + 1, "A") = s1.Cells(brn, "A")
    s2.Cells(ilk + 2, "A") = s1.Cells(brn, "A")
    s2.Cells(ilk + 3, "A") = s1.Cells(brn, "A")
Next
Msg[B][COLOR="Red"]Box[/COLOR][/B] "İŞLEM TAMAM"
[B]End Sub[/B]

 

[uygurmuhasebe]

Çok teşekkür ederim ilginiz için. Ancak dediklerinizi uyguladığımda şöyle bir hata alıyorum.

Compile error:

Sub or function not defined.

 

[Ömer BARAN]

End Sub satırından önceki kırmızı kısmı eksik yazmışım;
Msg değil MsgBox olarak düzeltmeniz yeterli (yukarıdaki cevabımı güncelledim).