Soru Sayı Kadar Satır Ekleme ve Sıralama

[clawee]

Merhaba çeki listemdeki çuval adeti kadar otomatik satır oluşturup 1 den başlayıp aşağı doğru sıralacak sekilde numaralayıp adetini girmesini istiyorum ama yapamadım. Yardımcı olmanızı rica ederim.

Örneğin bu şekildeki listeyi
S beden 30 çuval 30 adet
S beden 1 çuval 10 adet
M beden 10 çuval 30 adet
M beden 1 çuval 12 adet

toplam 42 satır 1 den 42 ye kadar gidecek şekilde sıraalanması adet bölümüde bu sıraya öre girilmesi gerekiyor.

1 30
2 30
3 30
....
31 10
32 30
....
42 12

Anlatımı biraz karışık oldu ama bu şekilde sıralatabilirsem diğer bilgilerin gelmesini ben sağlayabilirim.
Teşekkürler

 

[ÖmerFaruk]

Örnek dosyanız olmadığı için yeni bir excel dosyası yaptım.
Çuvallar ve Liste isimli 2 adet sayfa oluşturdum.
Çuvallar sayfasında A1 den başlayarak aşağıdaki resimdeki gibi verileri yazdım



Liste sayfasında A1 den başlayarak istediğiniz kadar liste satırını A-B sütunlarında oluşturdum.
Aşağıdaki kodu bir modül içine ekleyip çalıştırabilirsiniz.

Not: Koyu renkli belirtiğim ifadeleri doğru yapmanız şart.

Sub ÇuvalListele()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim satır As Integer
Dim k As Integer
    Set Sh1 = Sheets("Çuvallar")
    Set Sh2 = Sheets("Liste")
    satır = 0
    For i = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row
        bak = Replace(Sh1.Range("A" & i), " ", "")
        beden = 1 * Mid(bak, InStr(1, bak, "beden") + 5, InStr(1, bak, "çuval") - (InStr(1, bak, "beden") + 5))
        adet = 1 * Mid(bak, InStr(1, bak, "çuval") + 5, InStr(1, bak, "adet") - (InStr(1, bak, "çuval") + 5))
        For k = 1 To beden
            Sh2.Range("A" & satır + k) = satır + k
            Sh2.Range("B" & satır + k) = adet
        Next k
        satır = satır + k - 1
    Next i
End Sub

 

[clawee]

Elinize sağlık formul çok güzel olmuş ama 3. sütüna beden eklememiz mümkünmü ?

1 30 S gibi

 

[ÖmerFaruk]

İkinci for döngüsüne bir satır ilave ettim

Sub ÇuvalListele()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim satır As Integer
Dim k As Integer
    Set Sh1 = Sheets("Çuvallar")
    Set Sh2 = Sheets("Liste")
    satır = 0
    For i = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row
        bak = Replace(Sh1.Range("A" & i), " ", "")
        beden = 1 * Mid(bak, InStr(1, bak, "beden") + 5, InStr(1, bak, "çuval") - (InStr(1, bak, "beden") + 5))
        adet = 1 * Mid(bak, InStr(1, bak, "çuval") + 5, InStr(1, bak, "adet") - (InStr(1, bak, "çuval") + 5))
        For k = 1 To beden
            Sh2.Range("A" & satır + k) = satır + k
            Sh2.Range("B" & satır + k) = adet
            ' burayı ilave edebilirsiniz'
            Sh2.Range("C" & satır + k) = Left(bak, 1)
        Next k
        satır = satır + k - 1
    Next i
End Sub

 

[clawee]

Çiftli yada 3 lü bedenlerde işe yaramadı örneğin

1 30 S
1 30 XL
1 30 2XL gibi

Bu durumda

1 30 S
1 30 X
1 30 2

olarak veriyor.

 

[veyselemre]

Sub ÇuvalListele()
    Dim Sh1 As Worksheet
    Dim Sh2 As Worksheet
    Dim satır As Integer
    Dim k As Integer
    Set Sh1 = Sheets("Çuvallar")
    Set Sh2 = Sheets("Liste")
    Sh2.Cells.ClearContents
    satır = 0
    For i = 1 To Sh1.Range("A" & Rows.Count).End(xlUp).Row
        bol = Split(Sh1.Range("A" & i), " ")
        beden = bol(0)
        cuval = bol(2)
        adet = bol(4)
        For k = 1 To cuval
            Sh2.Range("A" & satır + k) = satır + k
            Sh2.Range("B" & satır + k) = adet
            Sh2.Range("C" & satır + k) = beden
        Next k
        satır = satır + k - 1
    Next i
End Sub

 

[ÖmerFaruk]

Çiftli yada 3 lü bedenlerde işe yaramadı örneğin

1 30 S
1 30 XL
1 30 2XL gibi

Bu durumda

1 30 S
1 30 X
1 30 2

olarak veriyor.

Verdiğiniz örnekte Bedenleri TEK HARF vermiştiniz.
Sorunuzda yeter kadar açıklamayı sunmanız şart.

Veysel beyin çözümü ihtiyacınızı karşılıyor olsa gerek.