Hücredeki Değer Kadar Satır Ekleme

[kozmiktekno]

Merhabalar,

Bir sorun ile karşı karşıyayım. Örneğin: A sütunundaki hücrelerde yazan değerler kadar alt alta satır açmam gerekiyor. Buradaki forumdan bir kod buldum ve çalıştırdım ancak bunu sadece tek bir hücre için yapıyor. Satır açmak için kullanacağım sayı değerleri 1000 adete kadar çıkabiliyor. Yani A sütununda 1000 hücrelik değer girmiş olsam bile o 1000 hücredeki değerlere göre altlarına satır açması gerekiyor.

Buradan bulup çalıştırdığım kod bu:

Sub satirrekle()
Dim sat As Integer
    sat = Range("A1").Value
    If sat = 0 Then Exit Sub
    Rows(2 & ":" & 1 + sat).Insert Shift:=xlDown
End Sub

Kodu bulduğum konu: https://www.excel.web.tr/threads/huecre-degeri-kadar-satir-ekleme-makrosu-ariyorum.173464/

Yardımınız için şimdiden teşekkür ederim.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub satir_ekle()

sonsatir = Cells(Rows.Count, "A").End(3).Row

For a = sonsatir To 1 Step -1

If Cells(a, "A") <> "" Then

Rows(a + 1 & ":" & a + Cells(a, "A")).Insert Shift:=xlDown

End If

Next

End Sub

 

[kozmiktekno]

Aşağıdaki kodu deneyin.

Sub satir_ekle()

sonsatir = Cells(Rows.Count, "A").End(3).Row

For a = sonsatir To 1 Step -1

If Cells(a, "A") <> "" Then

Rows(a + 1 & ":" & a + Cells(a, "A")).Insert Shift:=xlDown

End If

Next

End Sub

Çok teşekkür ederim Levent Bey.

 

[kozmiktekno]

Özür dilerim, bir yeri atlamışım. Şöyle ki açılacak olan satırların sayısı hücredeki değerin 1 eksiği kadar olmasına ihtiyacım var. Yani hücrede 2 yazıyorsa alta 1 satır açmalı ya da 7 yazıyorsa 6 satır açmalı gibi.

 

[Levent Menteşoğlu]

Aşağıdaki gibi düzenlemeniz yeterlidir.

Sub satir_ekle()

sonsatir = Cells(Rows.Count, "A").End(3).Row

For a = sonsatir To 1 Step -1

If Cells(a, "A") > 1 Then

Rows(a + 1 & ":" & a + Cells(a, "A") - 1).Insert Shift:=xlDown

End If

Next

End Sub

 

[kozmiktekno]

Aşağıdaki gibi düzenlemeniz yeterlidir.

Sub satir_ekle()

sonsatir = Cells(Rows.Count, "A").End(3).Row

For a = sonsatir To 1 Step -1

If Cells(a, "A") > 1 Then

Rows(a + 1 & ":" & a + Cells(a, "A") - 1).Insert Shift:=xlDown

End If

Next

End Sub

Sağolun Levent Bey, çok teşekkür ederim.