Verileri alt alta tekrar ettiren makro ile ilgili bir soru

[bilal5412]

Merhaba arkadaşlar,

Aşağıdaki makro, 7. sütundaki değer kadar 1. sütundan 7. sütunda dahil tüm verileri tekrar ettirek yazdırıyor.

Soru ise ; 7.sütun olarak belirtilen bu makro sütün bilgi girin diye bir sorgu ile hangi sütundan itibaren tüm satırı alt alta tekrar ettirebilir diye bir sorgu ekleyebiliriz ?

Sub alt()
Dim i&: i = 2
While Cells(i, 7) <> ""
If Cells(i, 7) = 1 Then i = i + 1
With Cells(i, 1)
Range(.Offset(1, 0), .Offset(Cells(i, 7) - 1, 0)).EntireRow.Insert Shift:=4
Range(.Offset(0, 0), .Offset(Cells(i, 7) - 1, 7)).FillDown
End With
i = i + Cells(i, 7)
Wend
i = Empty
End Sub

 

[Emir Hüseyin Çoban]

. . .

Başlangıç ve bitiş olarak 2 kez mi soracak.
Yoksa siz işlemi artık tek sütunda mı çalıştırmak istiyorsunuz.

. . .

 

[bilal5412]

. . .

Başlangıç ve bitiş olarak 2 kez mi soracak.
Yoksa siz işlemi artık tek sütunda mı çalıştırmak istiyorsunuz.

. . .

Tek sütun için çalışacaktır.

Yani kodda belirtilen 7 leri ben manuel olarak 5 ve 6 veya 10. sütun gibi değiştiriyorum. Bunun yerine bana hangi sütun diye sorarsa daha iyi olur. Yardımlarınızı rica ederim.

 

[Emir Hüseyin Çoban]

. . .

Yine 1 den sizin girdiğiniz sütun sayısına kadar mı yapacak.

. . .

 

[bilal5412]

. . .

Yine 1 den sizin girdiğiniz sütun sayısına kadar mı yapacak.

. . .

Evet. ilgili sütunda ne kadar veri varsa o kadar işlem yapacak. Örnek olarak aşağıdaki bağlantıda çalışmam vardır.

https://drive.google.com/file/d/0B3wJKQcxKCV4NGZrRXNDUDhQS3c/view?usp=sharing

 

[Emir Hüseyin Çoban]

. . .

Sub alt()
    Dim i&: i = 2
    
    sor = InputBox("Sütun Sayısı Girin")
    If sor = "" Then Exit Sub
    
    If Not IsNumeric(sor) Then Exit Sub
    sor = sor * 1
    While Cells(i, sor) <> ""
    If Cells(i, sor) = 1 Then i = i + 1
    With Cells(i, 1)
        Range(.Offset(1, 0), .Offset(Cells(i, sor) - 1, 0)).EntireRow.Insert Shift:=4
        Range(.Offset(0, 0), .Offset(Cells(i, sor) - 1, 7)).FillDown
    End With
    i = i + Cells(i, sor)
    Wend
    i = Empty
End Sub

. . .

 

[bilal5412]

. . .

Sub alt()
    Dim i&: i = 2
    
    sor = InputBox("Sütun Sayısı Girin")
    If sor = "" Then Exit Sub
    
    If Not IsNumeric(sor) Then Exit Sub
    sor = sor * 1
    While Cells(i, sor) <> ""
    If Cells(i, sor) = 1 Then i = i + 1
    With Cells(i, 1)
        Range(.Offset(1, 0), .Offset(Cells(i, sor) - 1, 0)).EntireRow.Insert Shift:=4
        Range(.Offset(0, 0), .Offset(Cells(i, sor) - 1, 7)).FillDown
    End With
    i = i + Cells(i, sor)
    Wend
    i = Empty
End Sub

. . .

Sorum çözülmüştür. Teşekkürler emeğinize sağlık. Allah razı olsun.