Stoklar arası satır açma

[altan888]

Merhabalar,
Ekteki excel tablosunda depo stok sayım listesi bulunmaktadır ve depoda bir stok farklı yerlere parça parça yerleştirilmiş olabilir, bu sebeple bir stoğun birden fazla sayım miktarı olabilir ve bu listedeki bir çok stok miktarları ardışık olarak listelenmiştir.

Benim sizden ricam; bir stok örneğin "Astar" stoğu sayım miktarları 6 satırdan oluşmaktadır, örneğin "Kumaş" stoğu sayım miktarları 3 satırdan oluşmaktadır, örneğin "Tela" stoğu sayım miktarları 9 satırdan oluşmaktadır,

Ancak benim istediğim "Astar" stoğu 6 satırlık listenin sonuna 4 satır daha boş satır ekleyerek "Astar" stoğu için toplamda 10 satırdan oluşan bir yer oluşturmak, aynı şekilde "Kumaş" stoğu 3 satırlık listenin sonuna 7 satır daha boş satır ekleyerek "Kumaş" stoğu için toplamda 10 satırdan oluşan bir yer oluşturmak , ve böylece diğer stokları da bu şekilde yapmak istiyorum, "bu yeni listeyi aynı veya başka bir sayfaya nasıl bir formülle satır ekleyerek oluşturabilirim" ve bunu "makrosuz" nasıl yaparım, yardımcı olmanızı rica ederim, yardımlar için şimdiden çok teşekkürler.

 

[Ziynettin]

Merhaba;

Makrolu çözüm

Sub Satir_Ac()
a = Range("A3:D" & Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If Not d.exists(a(i, 2)) Then
        say = say + 1
        d(a(i, 2)) = say
        b(say, 1) = a(i, 2)
    End If
    b(d(a(i, 2)), 2) = b(d(a(i, 2)), 2) + 1
Next i

tbl = Array(b)
say = 0
ReDim c(1 To d.Count * 10, 1 To 4)
For x = 1 To d.Count
    For j = 1 To d.Count * 10
        sira = sira + 1
        c(j, 1) = sira
        If sira = 10 Then sira = 0
    Next j
    For i = 1 To UBound(a)
        If a(i, 2) = tbl(0)(x, 1) Then
            say = say + 1
            c(say, 2) = a(i, 2)
            c(say, 3) = a(i, 3)
            c(say, 4) = a(i, 4)
        End If
    Next i
    say = (say + 10) - Val(tbl(0)(x, 2))
Next x
Range("G3:J" & Rows.Count).ClearContents
[G3].Resize(say, 4) = c
MsgBox "İşlem tamam...", vbInformation
End Sub

 

[muygun]

Merhaba;
Ekteki örnekleri deneyin.
Önerim makrolu çözümleri tercih etmeniz. (görüldüğü gibi formülle çözüm makrodan daha karmaşık)
İyi çalışmalar.

 

[altan888]

Merhaba;

Makrolu çözüm

Sub Satir_Ac()
a = Range("A3:D" & Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To 2)
For i = 1 To UBound(a)
    If Not d.exists(a(i, 2)) Then
        say = say + 1
        d(a(i, 2)) = say
        b(say, 1) = a(i, 2)
    End If
    b(d(a(i, 2)), 2) = b(d(a(i, 2)), 2) + 1
Next i

tbl = Array(b)
say = 0
ReDim c(1 To d.Count * 10, 1 To 4)
For x = 1 To d.Count
    For j = 1 To d.Count * 10
        sira = sira + 1
        c(j, 1) = sira
        If sira = 10 Then sira = 0
    Next j
    For i = 1 To UBound(a)
        If a(i, 2) = tbl(0)(x, 1) Then
            say = say + 1
            c(say, 2) = a(i, 2)
            c(say, 3) = a(i, 3)
            c(say, 4) = a(i, 4)
        End If
    Next i
    say = (say + 10) - Val(tbl(0)(x, 2))
Next x
Range("G3:J" & Rows.Count).ClearContents
[G3].Resize(say, 4) = c
MsgBox "İşlem tamam...", vbInformation
End Sub

Sayın Ziynettin,
Cevap için çok çok teşekkürler.

 

[altan888]

Merhaba;
Ekteki örnekleri deneyin.
Önerim makrolu çözümleri tercih etmeniz. (görüldüğü gibi formülle çözüm makrodan daha karmaşık)
İyi çalışmalar.

Sayın muygun,
Cevap için çok çok teşekkürler. formüllerinizi hafta sonu daha geniş bir zamanda inceleyip çözmek istiyorum, elinize sağlık, iyi çalışmalar dilerim.