Hücre değerine göre kopyalama yapmak

[memetcirak]

Merhaba

ekli dosyada olduğu gibi eğer b1 de değer 2 ise a1 deki değeri 2 kere altalta kopyalatmak devamında b2 deki değer 4 ise bunuda a1 için oluşturulan kopyaların altına ekleyerek devam etmesi.Umarım anlatabilmişimdir.Şimdiden teşekkürler.

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub ekle_59()
Dim list1(), list2(), i As Long, sat1 As Long, sat2 As Long, j As Integer
Range("D6:D" & Rows.Count).ClearContents
list1 = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
sat2 = WorksheetFunction.Sum(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
ReDim list2(1 To 1, 1 To sat2)
sat1 = 1
For i = 1 To UBound(list1)
    For j = 1 To list1(i, 2)
        list2(1, sat1) = list1(i, 1)
        sat1 = sat1 + 1
    Next j
Next i
Erase list1
Application.ScreenUpdating = False
Range("D6").Resize(sat2, 1) = Application.Transpose(list2)
Application.ScreenUpdating = True
Erase list2
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, Application.UserName
End Sub

 

[memetcirak]

çok teşekkür ederim yardımınız için