Bir veriyi adetine göre birden fazla veri haline getirme

[Tornael]

Selam Arkadaşlar,

Başlıkta da belirttiğim gibi ekteki excelde de örnekleyerek anlatmaya çalıştım.

İlgileriniz için şimdiden teşekkür ederim.

 

[sakman26]

selam,
eki inceleyiniz..
kolay gelsin...

 

[Tornael]

Tebrikler

Harbiden eğer formülü ile çözülebileceği hiç aklıma gelmezdi.
Henüz tecrübesizim:redface:

Zekanıza sağlık.

 

[Necdet]

Merhaba,

Bir kaç veri olduğunda formülle sıkıntı yaşayabilirsiniz. Makroyu deneyiniz. Değişik yöntemlerle olabilir.

Sub Cogalt()
    
    Dim i   As Long
    Dim Bs  As Long
    Dim Bt  As Long
    
    Bs = 2
    
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        Bt = Bs + Cells(i, "B") - 1
        Range("D" & Bs & ":D" & Bt) = Cells(i, "A")
        Range("E" & Bs & ":E" & Bt) = 1
        Bs = Bs + Cells(i, "B")
    Next i
    
End Sub

 

[Tornael]

Tebrik ediyorum

Onunla uğraşıyordum bende, stun stun ayırıyordum kodları. Resmen aklımı okudunuz çok saolun Necdet Bey.:bravo:

 

[Necdet]

Merhaba,

Veri Üzerinde değişiklik isterseniz ya da başka bir yöntem isterseniz kodları inceleyiniz.

Son Satırdaki Range("A2....
ve Range("B2...

leri değiştirirseniz başka sütünlara listeyi alabilirsiniz.

Sub Cogalt2()
 
    Dim i   As Long, _
        j   As Long, _
        k   As Integer, _
        l   As Long, _
        Son As Long, _
        dz()
 
    Son = Cells(Rows.Count, "A").End(3).Row
 
    j = Evaluate("=SUM(B2:B" & Son & ")")
    ReDim dz(1 To j)
 
    For i = 2 To Son
        For k = 1 To Cells(i, "B")
            l = l + 1
            dz(l) = Cells(i, "A")
        Next k
    Next i
 
    Range("A2").Resize(j, 1) = Application.WorksheetFunction.Transpose(dz)
    Range("B2:B" & j + 1) = 1
 
End Sub

 

[Tornael]

Teşekkürler üstadım