Yazan sayı kadar makro ile çoğaltmak

[bornovalı1]

Merhaba;

Tabloda kodların yanındaki sutunda yazan rakam kadar kodu diğer yanındaki sutuna yazsın istiyorum.
Yardımcı olursanız sevinirim .

 

[ÖmerBey]

Merhaba,
Örnek dosyanız için aşağıdaki kodu deneyiniz.

Sub KOD()
For a = 1 To Range("A65500").End(3).Row
    If Cells(a, "B") > 0 Then
        Do
            x = x + 1
            Cells(x, "E") = Cells(a, "A")
            say = say + 1
        Loop While say < Cells(a, "B")
        say = 0
    End If
Next
End Sub

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
    Application.ScreenUpdating = False
    
    Range("E:E").ClearContents
    
    If Range("E1") = "" Then
        sonsat = "1"
    Else
        sonsat = Cells(Rows.Count, "E").End(3).Row + 1
    End If
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        
        If Cells(i, "B") > 0 Then
            
            If Cells(i, "B") = 1 Then
                s = 0
            Else
                s = Cells(i, "B") - 1
            End If
            
            Range("E" & sonsat & ":E" & sonsat + s) = Cells(i, "A")
            sonsat = Cells(Rows.Count, "E").End(3).Row + 1
            
        End If
        
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
    
End Sub

. . .

 

[bornovalı1]

Mucit bey ve hüseyin bey ilginiz için teşekkür ederim.
Her iki kod da çalışıyor.Fakat çalıştırınca farkettim sıfırları göstermiyor ok ama benim için bir yazanlarıda göstermemesi ve mesela 2 yazıyorsa bir eksiği yani bir satır yazması 3 yazıyorsa 2 satır yazması gerektiğini anladım.
Hüseyin bey hangi satırlarda değişiklik yapmak gerekiyor bilgi verebilirseniz sevinirim

 

[Emir Hüseyin Çoban]

Mucit bey ve hüseyin bey ilginiz için teşekkür ederim.
Her iki kod da çalışıyor.Fakat çalıştırınca farkettim sıfırları göstermiyor ok ama benim için bir yazanlarıda göstermemesi ve mesela 2 yazıyorsa bir eksiği yani bir satır yazması 3 yazıyorsa 2 satır yazması gerektiğini anladım.
Hüseyin bey hangi satırlarda değişiklik yapmak gerekiyor bilgi verebilirseniz sevinirim

. . .

Sub KOD()
    Application.ScreenUpdating = False
    
    Range("E:E").ClearContents
    
    If Range("E1") = "" Then
        sonsat = "1"
    Else
        sonsat = Cells(Rows.Count, "E").End(3).Row + 1
    End If
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
        
        If Cells(i, "B") [COLOR="blue"][B]> 1[/B][/COLOR] Then
            
            If Cells(i, "B") = 1 Then
                s = 0
            Else
                s = Cells(i, "B") [B][COLOR="Blue"]- 2[/COLOR][/B]
            End If
            
            Range("E" & sonsat & ":E" & sonsat + s) = Cells(i, "A")
            sonsat = Cells(Rows.Count, "E").End(3).Row + 1
            
        End If
        
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
    
End Sub

. . .

 

[bornovalı1]

Hüseyin bey ;
Elinize sağlık sorunsuz çalışıyor.
Makro ile ilgili bir sorum daha olacak eğer vaktiniz olur ilgilenirseniz sevinirim.
Teşekkür ederim.
http://www.excel.web.tr/f14/tarihe-gore-makro-ile-kopyalama-t147002.html#post798730