Satır ekleme, eklenen satırı doldurma..

[tirEdsOuL]

Merhaba;

Sub Üç_Satir_Ekle()
    Dim a As Byte, sat As Byte
    [A2].Select
    a = 4: sat = 3
    While ActiveCell.Value <> ""
        ActiveSheet.Rows(ActiveCell.Row & ":" & sat + ActiveCell.Row - 1).Insert Shift:=xlDown
        ActiveCell.Offset(a, 0).Select
    Wend
    a = Empty: sat = Empty
End Sub

Yukarıdaki kod ile örneğin A2:A6 arasında dolu olan hücrelerin aralarına 3 satır açıyor. Ben ise bu açılan satırların arasını doldurmasını istiyorum. Yani A2 de ne yazıyor ise, üstüne açılan 3 satırada aynısını yazmasını istiyorum, A3'ün üstüne açılan satır için de aynısı diye devam ediyor..
Örnek dosya ektedir.

 

[veyselemre]

Sub test1()
    a = WorksheetFunction.Transpose(Range("A2:A" & Cells(Rows.Count, "A").End(3).Row).Value)
    sat = 2
    For i = 1 To UBound(a)
        If a(i) <> "" Then
            Cells(sat, 1).Resize(4, 1).Value = a(i)
            sat = sat + 4
        End If
    Next i
End Sub
Sub test2()
    For i = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
        If Cells(i, 1) <> "" Then
            Cells(i + 1, 1).Resize(3, 1).EntireRow.Insert Shift:=xlDown
            Cells(i, 1).Resize(4, 1).FillDown
        End If
    Next i
End Sub

 

[tarhan822]

istediğiniz olmuş mu kontrol ediniz.

 

[tirEdsOuL]

Sub test1()
    a = WorksheetFunction.Transpose(Range("A2:A" & Cells(Rows.Count, "A").End(3).Row).Value)
    sat = 2
    For i = 1 To UBound(a)
        If a(i) <> "" Then
            Cells(sat, 1).Resize(4, 1).Value = a(i)
            sat = sat + 4
        End If
    Next i
End Sub
Sub test2()
    For i = Cells(Rows.Count, "A").End(3).Row To 2 Step -1
        If Cells(i, 1) <> "" Then
            Cells(i + 1, 1).Resize(3, 1).EntireRow.Insert Shift:=xlDown
            Cells(i, 1).Resize(4, 1).FillDown
        End If
    Next i
End Sub

Veysel bey, siz iki alternatif sunmuşsunuz sanırım.. her ikisi de sorunsuz çalışıyor teşekkürler..

istediğiniz olmuş mu kontrol ediniz.

tarhan bey sizin verdiğiniz kod da çalışıyor ama exceli çok kasıyor ve işlem sonunda son satırı komple kopyalıyor.