Belli sayıdaki değerleri istenilen farklı sayılarda çoğaltma

[votkaredbul]

Adet​	Değer​
14​	1,248571 ₺​
21​	1,358095 ₺​
22​	1,620455 ₺​
20​	1,610000 ₺​
22​	1,620455 ₺​
20​	1,725000 ₺​
22​	1,620455 ₺​
20​	1,725000 ₺​
22​	1,620455 ₺​

Merhaba,
A2 hücresindeki adet sayısınca B2 değerinden alt alta çoğaltmak istiyorum. Bu şekilde elimde 2.500'e yakın satır var, şimdiden teşekkürler.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
    SonSatir = 1
    Range("C1:C" & Rows.Count).ClearContents
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        Range("C" & SonSatir + 1 & ":C" & SonSatir + Cells(Bak, "A").Value).Value = Cells(Bak, "B").Value
        SonSatir = Cells(Rows.Count, "C").End(xlUp).Row
    Next
    MsgBox "Tamamlandı."
End Sub

 

[votkaredbul]

Kod için çok teşekkür ederim tam istediğim gibi çalıştı fakat şöyle bir sıkıntı yaşadım ki ; B2 değerleri birebir aynı değilde yukarı yuvarlanmış şekilde çalıştı bunu nasıl düzeltebilirim ?

 

[Korhan Ayhan]

Merhaba,

C sütununda hücre biçimlendirme yaparsanız sanırım sonuç alabilirsiniz.

 

[votkaredbul]

Denedim fakat olmadı, sayılar düz çıkıyor.

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Eğer yine de olmuyorsa dosyanızı dosya.co gibi bir paylaşım sitesinde paylaşın kontrol edelim.

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
    SonSatir = 1
    Range("C1:C" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        With Range("C" & SonSatir + 1 & ":C" & SonSatir + Cells(Bak, "A").Value)
            .Value = Cells(Bak, "B").Value
            .Style = Cells(Bak, "B").Style
        End With
        SonSatir = Cells(Rows.Count, "C").End(xlUp).Row
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub

 

[votkaredbul]

Olmadı hocam, gönderiyorum.

İndir excel kod xlsx

Dosyayı indir excel kod xlsx

dosya.co

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin.

Sub Test()
    Dim Bak As Long
    Dim SonSatir As Long
    Dim m As Double
    
    SonSatir = 1
    Range("C1:C" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    For Bak = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        With Range("C" & SonSatir + 1 & ":C" & SonSatir + Cells(Bak, "A").Value)
            .Value = --Cells(Bak, "B").Text
        End With
        SonSatir = Cells(Rows.Count, "C").End(xlUp).Row
    Next
    Application.ScreenUpdating = True
    MsgBox "Tamamlandı."
End Sub

 

[votkaredbul]

Ellerinize sağlık, çok teşekkür ederim. Çalıştı.

 

[ÖmerBey]

Merhaba,
Alternatif olarak 6 numaralı mesajdaki ilgili satır aşağıdaki gibi değiştirilebilir.
İyi çalışmalar...

.Value = Cells(Bak, "B").Value2