Soru Hücredeki Sayıya Göre Veri Ekleme

[leonadies]

Arakadaşlar Merhaba;

B:B sütununa girilen sayıyı C:C sütununda karşısına girilen sayı ne ise o oranda "Paket 1,Paket 2,Paket 3, ............." şeklinde yazmasını istiyorum.
Not: Virgül sayısıda sayı ile aynı olmalı ve virgülün önünde arkasında boşluk olmamalı

Yapılabilir mi bu isteğim ?

 

[hmtstc]

deneyiniz.

Sub cogalt()
Dim say As Long
For i = 1 To Cells(Rows.Count, 3).End(xlUp).Row
say = Cells(i, 3)
If say = emtpy Then GoTo 10


bas = 1
paket = "Paket "
metin = ""
Do
metin = metin & paket & bas & ","
bas = bas + 1
Loop Until bas = say + 1
Cells(i, 4) = metin
10
Next i

End Sub

 

[leonadies]

Malesef hiç birşey yapmıyor bu kodlar

deneyiniz.

 

[Korhan Ayhan]

Alternatif,

Hız olarak avantaj sağlayabilir.

Option Explicit

Sub Veri_Ekle()
    Dim Veri As Variant, Son As Long, X As Long, Metin As String
    Dim Y As Integer, Dizi As Object, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 2).End(3).Row
    If Son = 1 Then Son = 2
    Veri = Range("B1:B" & Son).Value
    
    Range("C:C").Clear
    
    Metin = "Paket "
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If IsNumeric(Veri(X, 1)) Then
            For Y = 1 To Veri(X, 1)
                Dizi.Add Metin & Y, Nothing
            Next
            Liste(X, 1) = Join(Dizi.Keys, ",") & ","
            Dizi.RemoveAll
        End If
    Next
    
    Range("C1").Resize(UBound(Veri)) = Liste
    
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[hmtstc]

Makro kullanmayı biliyor musunuz?

 

[leonadies]

Elbette üstadım. Kodda bir sıkıntı var ama. Müdahele falan ettim ama sağlıklı çalışmadı.

Makro kullanmayı biliyor musunuz?

 

[leonadies]

@Korhan Ayhan Hocam teşekkür ederim. Tam istediğim gibi

 

[hmtstc]

hocam ben C ile D ye yapmışım, siz B ile C demişsiniz, benim hatam olmuş,

kod aşağıdaki gibi,

Sub cogalt()
Dim say As Long
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
say = Cells(i, 2)
If say = emtpy Then GoTo 10


bas = 1
paket = "Paket "
metin = ""
Do
metin = metin & paket & bas & ","
bas = bas + 1
Loop Until bas = say + 1
Cells(i, 3) = metin
10
Next i

End Sub

 

[leonadies]

Hocam onu fark ettim düzeltmeyi kendim yaptım ama. Makro istikrarlı çalışmamıştı. Ama bu son halini denedim tamamdır. Ellerine sağlık