İsimleri adetleri kadar yazdırma

[Fyzyc]

Arkadaşlar merhaba,

Ekte verdiğim dosyada sayfa 1 de yer alan isimler ve karşısındaki adetler kadar sayfa 2 ye isim yazdırmak istiyorum, yani Ahmet 1 50 tane altalta A2 den A52 ye kadar devamında Ahmet 2 A53 ten A80'e kadar gibi, yardımcı olabilir msiiniz?

Teşekkürler

http://www.dosya.tc/server35/VxHZJm/Fyzyc.xlsx.html

 

[Emir Hüseyin Çoban]

. . .

Dosyanız ektedir.

Sub KOD_DİZİ()
    Application.ScreenUpdating = False
    
    Dim S1 As Worksheet: Set S1 = Sheets("Sheet1")
    Dim S2 As Worksheet: Set S2 = Sheets("Sheet2")
    
    S2.Range("A:A").ClearContents
    S2.Range("A1") = "İsim"
    
    ReDim dizi(1 To 1, 1 To 1)
    For i = 2 To S1.Cells(Rows.Count, "A").End(3).Row
        If S1.Cells(i, "A").Value <> "" Then
            For a = 1 To S1.Cells(i, "B")
                s = s + 1
                ReDim Preserve dizi(1 To 1, 1 To s)
                dizi(1, s) = S1.Cells(i, "A").Value
            Next a
        End If
    Next i
    S2.Range("A2").Resize(s, 1).Value = Application.Transpose(dizi)
    
    Application.ScreenUpdating = True
    MsgBox "B i t t i "
End Sub

. . .

 

[Fyzyc]

Çok çok teşekkürler.