Hücre içinde olan verileri alt alta çoğaltmak

[kakara]

Merhaba ustadlarım ekte paylastıgım dosyada ham tablo ve olması gereken halı var işallah dogru anlatabılmıstırım derdımı şimdiden ilginiz için tesekkur ederım

 

[Muzaffer Ali]

Merhaba.
Başla Butonuna basarak deneyiniz.
Sayfa1'e istediğiniz şekilde aktarma yapar.

 

[Korhan Ayhan]

Merhaba,

Alternatif...

Dosyanıza bir sayfa daha ekleyin. (Adı Sayfa1 olsun..)

Sonra aşağıdaki kodu deneyiniz. Hız olarak biraz daha avantaj sağlayacaktır.

Option Explicit

Sub Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
    Dim Veri As Variant, X As Long, Say As Long
    Dim Y As Integer, Beden As Variant, Beden_Say As Byte
    
    Zaman = Timer
    
    Set S1 = Sheets("STOK_TEKLEME_URUN_LISTESI (1)")
    Set S2 = Sheets("Sayfa1")
    
    S2.Range("A2:N" & S2.Rows.Count).Clear
    
    Veri = S1.Range("A2:N" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
    
    ReDim Liste(1 To S2.Rows.Count, 1 To 14)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Say = Say + 1
            For Y = 1 To 14
                Liste(Say, Y) = Veri(X, Y)
            Next
            
            Beden_Say = 5
            
            For Each Beden In Split(Veri(X, 4), "-")
                Say = Say + 1
                For Y = 1 To 4
                    Select Case Y
                        Case 4: Liste(Say, Y) = Beden
                        Case Else: Liste(Say, Y) = Veri(X, Y)
                    End Select
                Next
                Liste(Say, Y) = Veri(X, Beden_Say)
                Beden_Say = Beden_Say + 1
            Next
        End If
    Next
    
    If Say > 0 Then
        S2.Range("A2").Resize(Say, UBound(Liste, 2)) = Liste
        S2.Columns.AutoFit
        S2.Select
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[kakara]

@Korhan Ayhan ustadım ılgınız ıcın tesekkurler yalnız ekte gönderdıgım hatayı verdı malesef kodunuz. ilginiz için şimdiden teşekkurler




@Muzaffer Ali ustadım ılgınız ıcın tesekkur ederım sanırım ben rıcamı tam anlatamadım sıze hucre ıcındekı bedenler alt alta gelıyor ama onun karşılıgındakı beden adetı malesef gelmıyor tablodakı b1 beden lıstesındekı ılk bedene b2 de ıkıncı bedene denk gelıyor ve boyle devam edıyor benım rıcam hangı bedenler adetlerı varsa onları alt alta yazdırdıgımızda karsılıgına yazıdrmaktı. ilginiz için şimdiden tesekkurler

 

[Korhan Ayhan]

Hata veren dosyayı paylaşma imkanınız var mı?

 

[Muzaffer Ali]

Aşağıdaki kodu deneyiniz.

Private Sub btnBasla_Click()
    Dim Bak As Long
    Dim SonSatir As Long
    Dim syfSon As Worksheet, syfHam As Worksheet
    Dim Beden As Variant
    Dim BakSon As Integer

    Set syfSon = Worksheets("Sayfa1")
    Set syfHam = Worksheets("STOK_TEKLEME_URUN_LISTESI (1)")
    
    If syfSon.Range("A2") <> "" Then syfSon.Range("A2:N" & syfSon.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
    For Bak = 2 To syfHam.Cells(Rows.Count, "A").End(xlUp).Row
        SonSatir = syfSon.Cells(Rows.Count, "A").End(xlUp).Row + 1
        Beden = Split(syfHam.Cells(Bak, "D"), "-")
        syfSon.Range("A" & SonSatir & ":N" & SonSatir).Value = syfHam.Range("A" & Bak & ":N" & Bak).Value
        SonSatir = SonSatir + 1
        syfSon.Range("A" & SonSatir & ":C" & SonSatir + UBound(Beden)).Value = syfHam.Range("A" & Bak & ":C" & Bak).Value

        For BakSon = 0 To UBound(Beden)
            syfSon.Cells(SonSatir, "D") = Beden(BakSon)
            syfSon.Range("E" & SonSatir).Value = syfHam.Cells(Bak, BakSon + 5) ' "E" & Bak & ":M" & Bak).Value
            SonSatir = SonSatir + 1
        Next
    Next
    MsgBox "Tamamlandı."
End Sub

 

[kakara]

@Muzaffer Ali ustadım ılgınız ıcın tesekkur ederım tam detaylı kontrol edemedım ama kodunuz calısıyor tablom uzun oldugu ıcın sonuna kadar bakamadım. bır aksaklık olursa sızden yardımınızı rıca ederım tekrardan tesekkur ederım ılgınıze.