Belli aralıkla satır açma

[jraujr]

Merhaba arkadaşlar,
A sütünunda alt alta 300 satırım var ben bunu başka bir exel sayfasına her 5 satırda 1 satır boşluk bırakarak yapıştırmak istiyorum.
Böyle bir şey mümkün mü?
veya 300 satırda her 5 satırın altında 1 boş satır bırakmak istiyorum.
Teşekkür ederim.

Örnekteki boşluıkları tek tek elle bırakmak zorunda kalıyorum 1000 i geçik satırım var. Bunu naısl hızlı bir şekilde yapabilirim.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub Satir_Ekle()

    Dim c As Range, i As Long
    
    Application.ScreenUpdating = False
    
    For i = 7 To Cells(Rows.Count, "A").End(xlUp).Row Step 5
        If c Is Nothing Then
            Set c = Rows(i)
        Else
            Set c = Application.Union(c, Rows(i))
        End If
    Next i
  
    If Not c Is Nothing Then c.Insert Shift:=xlDown
    
End Sub

 

[jraujr]

Merhaba,

Deneyiniz.

Sub Satir_Ekle()

    Dim c As Range, i As Long
   
    Application.ScreenUpdating = False
   
    For i = 7 To Cells(Rows.Count, "A").End(xlUp).Row Step 5
        If c Is Nothing Then
            Set c = Rows(i)
        Else
            Set c = Application.Union(c, Rows(i))
        End If
    Next i
 
    If Not c Is Nothing Then c.Insert Shift:=xlDown
   
End Sub

Özür dilerim ama kodu nereye yapıştıracağımı bilmiyorum... ) Tarif edermisniz?

 

[Ömer]

Alt + F11 ile VBA ekranında geçin, Insert menüsünden Module ekleyin. Açılan ekrana kodu yapıştırın, daha sonra bu sayfayı kapatın.

Kodları buton bağlayabilir yada Alt+F8 ile çalıştırabilirsiniz.

Excel çalışmanızı farklı kaydet bölümünden kayıt türünü "makro içerebilen excel çalışması" olarak kaydediniz.

 

[numan şamil]

Merhaba
her 5 satırda değilde A sutunundaki ürün farklılığında bir boşluk bırakır
Aşağıdaki kodu denermisiniz

Sub Satırekle()
Dim i As Long
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
If Cells(i, "A") <> "" And Cells(i - 1, "A") <> "" Then
    If Cells(i, "A") <> Cells(i - 1, "A") Then
       Range("A" & i & ":G" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     End If
     End If
Next
Application.ScreenUpdating = True
End Sub

 

[jraujr]

Merhaba
her 5 satırda değilde A sutunundaki ürün farklılığında bir boşluk bırakır
Aşağıdaki kodu denermisiniz

Sub Satırekle()
Dim i As Long
Application.ScreenUpdating = False
For i = [A65536].End(3).Row To 3 Step -1
If Cells(i, "A") <> "" And Cells(i - 1, "A") <> "" Then
    If Cells(i, "A") <> Cells(i - 1, "A") Then
       Range("A" & i & ":G" & i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
     End If
     End If
Next
Application.ScreenUpdating = True
End Sub

Teşekkür ederim bunu denemedim. Kodu farklı kaynaklardan edinmiştim daha önce. Sanırım sizinkiyle aynı zaten. Paylaşıyorum.
Ömer bey'e de teşekkür ederim.

Sub Satir_Ekle()
Dim a As Byte
Dim c As Integer
[A1].Select
a = 6
c = 0
   While ActiveCell.Value <> ""
      c = c + 6
      ActiveSheet.Rows(c).Insert Shift:=xlDown
      ActiveCell.Offset(a, 0).Select
   Wend
End Sub

Bu kod üstten sayar 5. satıra geldiğinde 6. satırı oluşturur ve boş bırakıp devam eder.
koddaki 6 rakamını değiştirerek satır atlama sayısını düzenleyebilirsiniz.
İyi günler..