İstenilen kadar sayı yazdırma

[qazxswedc321]

Merhaba,
Yapmak istediğim şudur:
B sütununda yazan sayılardan kaç tane olması gerektiği C sütunundadır.
Sonuç F sütununda gösterilmektedir. F sütununa B sütununda yazan sayıdan C sütunundaki kadar yazdırmaktır.
B sütunundaki sayılar en fazla 150 satırdır.
Örnek dosya ekledim.
Yardımcı olabilirseniz çok sevinirim.

 

[Ömer]

Merhaba,

Deneyiniz.

Sub test()
    
    Dim i As Long, sat As Long
    
    Application.ScreenUpdating = False
    Range("F3:F" & Rows.Count).Clear
    
    For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "C") > 0 And IsNumeric(Cells(i, "C")) = True Then
            sat = Cells(Rows.Count, "F").End(xlUp).Row + 1
            Cells(i, "B").Copy Cells(sat, "F").Resize(Cells(i, "C"), 1)
        End If
    Next i
    
End Sub

 

[qazxswedc321]

Sayın Ömer,
Gerçekten harikasınız, çok hızlı cevapladınız, çok çok teşekkür ederim.

 

[Ömer]

Rica ederim. Küçük bir değişiklik yaptım, son halini kullanırsınız.

 

[qazxswedc321]

Tekrardan çok teşekkür ediyorum.

 

[Korhan Ayhan]

Bu da dizi yöntemiyle alternatif olsun.

Hız olarak avantaj sağlayacaktır.

Option Explicit

Sub Listele()
    Dim Veri As Variant, X As Long, Son As Long, Y As Integer, Say As Long
    
    Range("F3:F" & Rows.Count).ClearContents
    
    Son = Cells(Rows.Count, 2).End(3).Row
    If Son < 4 Then Son = 4
    
    Veri = Range("B3:C" & Son).Value
    
    ReDim Liste(1 To Rows.Count, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If IsNumeric(Veri(X, 1)) Then
            If IsNumeric(Veri(X, 2)) And Veri(X, 2) > 0 Then
                For Y = 1 To Veri(X, 2)
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X, 1)
                Next
            End If
        End If
    Next
    
    If Say > 0 Then
        Range("F3").Resize(Say) = Liste
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı.", vbInformation
    End If
End Sub

 

[qazxswedc321]

Korhan Bey mesajınızı yeni gördüm, yardımlarınız için çok teşekkür ederim.