Aynı Satıları 4 defa Yazdırma

[xnanx]

Merhabalar,
Excel basit bir şeye ihtiyacım var ama bir türlü yapamadım.


Yüzlerce satır için uygulamam gerekli basit bir örnek ile yaptım.

Tablom da Malzeme ismi, tarih ve tutar var
Sol taraftaki satırların hepsi için, bütün satırları 4 defa yazdırıp tutarı 4 bölüp, tarihleri de 7 şer gün artırmak istiyorum.

Yardımlarınız ve yönlendirmeleriniz için şimdiden teşekkür ederim.

 

[PriveT]

Merhaba,
Ömer Bey"in bir cevabından yola çıkarak hazırladığım dosyanız ekte.
Deneyiniz.

 

[halit3]

Alternatif olarak kod:

Sub deneme1()
Set s1 = Sheets("Sayfa1")
s1.Range("G3:K" & Rows.Count).ClearContents
sat = 3
For r = 3 To s1.Cells(Rows.Count, "A").End(3).Row
bol = s1.Cells(r, 5)
tarih = s1.Cells(r, 4)
For k = 1 To 4
s1.Cells(sat, 7) = s1.Cells(r, 1)
s1.Cells(sat, 8) = s1.Cells(r, 2)
s1.Cells(sat, 9) = s1.Cells(r, 3)
s1.Cells(sat, 10) = tarih
s1.Cells(sat, 11) = bol / 4
sat = sat + 1
tarih = CDate(tarih) + 7
Next k
Next r
MsgBox " Düzenleme Tamanlanmıştır..."
End Sub

 

[Korhan Ayhan]

Alternatif;

Bu kod da blok olarak aktarım yapıyor.

Sub Aktar()
    Range("H3:L" & Rows.Count).Clear
    Satir = 3
    Son = Cells(Rows.Count, 1).End(3).Row
    For X = 3 To Son
        If Cells(X, 1) <> "" Then
            Cells(Satir, "H").Resize(4, 3).Value = Cells(X, 1).Resize(1, 3).Value
            Cells(Satir, "K").Resize(4, 1).Value = "=" & Cells(X, 4).Address & "+LOOKUP(ROW(K1),{1,2,3,4},{0,6,13,20})"
            Cells(Satir, "K").Resize(4, 1).Value = Cells(Satir, "K").Resize(4, 1).Value
            Cells(Satir, "L").Resize(4, 1).Value = Cells(X, 5) / 4
            Satir = Satir + 4
        End If
    Next
    Range("H3:L" & Satir - 1).Borders.LineStyle = 1
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub