Satır Ekleyip Kopyalama

[dogu34]

Merhaba
Yardımcı olursanız sevinirim.
7.000 den fazla dolu satırım (sütun A-B-C-D) var öncelikle dolu satırların arasına 8 er adet boş satır ekleyip daha sonra ilk dolu satırları daha sonradan eklediğim boş satırlara kopyalamak istiyorum

 

[dEdE]

Merhaba,
Aşağıdaki kodları bir modüle yapıştırarak dener misiniz?

Sub BosSatirEkle()
    Application.ScreenUpdating = False
    ss = Range("A" & Rows.Count).End(xlUp).Row
    For j = ss To 2 Step -1
        For i = 1 To 8
            Rows(j).Insert Shift:=xlDown
        Next i
        Range("A" & j - 1 & ":D" & j - 1).Copy Range("A" & j).resize(8)
    Next j
    Application.ScreenUpdating = True
End Sub

 

[Muzaffer Ali]

Merhaba.

Hızlı çalışan alternatif kod.
Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.

Sub Test2()
    Dim Bak As Long
    Dim VeriK As Variant
    Dim VeriS As Variant
    Dim Ekle As Integer
    Dim Sira As Long
    VeriK = Range("A2:D" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim VeriS(1 To UBound(VeriK) * 9, 1 To 4)
    For Bak = 1 To UBound(VeriK)
        For Ekle = 1 To 9
            Sira = Sira + 1
            VeriS(Sira, 1) = VeriK(Bak, 1)
            VeriS(Sira, 2) = VeriK(Bak, 2)
            VeriS(Sira, 3) = VeriK(Bak, 3)
            VeriS(Sira, 4) = VeriK(Bak, 4)
        Next
    Next
    Range("A2:D" & UBound(VeriS) + 1).Value = VeriS
End Sub

 

[dogu34]

Merhaba,
Aşağıdaki kodları bir modüle yapıştırarak dener misiniz?

Sub BosSatirEkle()
    Application.ScreenUpdating = False
    ss = Range("A" & Rows.Count).End(xlUp).Row
    For j = ss To 2 Step -1
        For i = 1 To 8
            Rows(j).Insert Shift:=xlDown
        Next i
        Range("A" & j - 1 & ":D" & j - 1).Copy Range("A" & j).resize(8)
    Next j
    Application.ScreenUpdating = True
End Sub

Teşekkürler hocam emeğinize sağlık

 

[dogu34]

Merhaba.

Hızlı çalışan alternatif kod.
Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.

Sub Test2()
    Dim Bak As Long
    Dim VeriK As Variant
    Dim VeriS As Variant
    Dim Ekle As Integer
    Dim Sira As Long
    VeriK = Range("A2:D57").Value
    ReDim VeriS(1 To UBound(VeriK) * 9, 1 To 4)
    For Bak = 1 To UBound(VeriK)
        For Ekle = 1 To 9
            Sira = Sira + 1
            VeriS(Sira, 1) = VeriK(Bak, 1)
            VeriS(Sira, 2) = VeriK(Bak, 2)
            VeriS(Sira, 3) = VeriK(Bak, 3)
            VeriS(Sira, 4) = VeriK(Bak, 4)
        Next
    Next
    Range("A2:D" & UBound(VeriS) + 1).Value = VeriS
End Sub

Teşekkürler hocam emeğinize sağlık

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.