Sütun Gruplama

[tasad]

Merhaba arkadaşlar
a sutununda sıra ile gidip b sutununda miktarlar 25 i geçtiğinde yeni grup oluşturacak.
Aşağıdaki şekilde bir yapı oluşturmak için vba kodunu yazamadım.
Yardımlarınız için şimdiden teşekkürler.

no miktar
1-- 5
2-- 12
3-- 7
4-- 9
5-- 15
6-- 4
7-- 17
8-- 22
9-- 5
10-- 6

olması geren bu şekilde
1 5
2 12
3 7
toplam 24

4 9
5 15
toplam 24

6 4
7 17
toplam 21

8 22
toplam 22

9 5
10 6
11 8
toplam 19

[erseldemirel]

Buna benzer bir işlem yapmıştım. A1 den A10 a kadar 1...10 yazın. B1 den B10 a akadarda 5,12,7.... 6 yazın. C sütununa grupları verir. Belki işinizi görür


Sub Test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("test")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim grup As Integer
grup = 1
Dim toplamMiktar As Double
toplamMiktar = 0
Dim i As Long
For i = 1 To lastRow
toplamMiktar = toplamMiktar + ws.Cells(i, "B").Value
If toplamMiktar > 25 Then
grup = grup + 1
toplamMiktar = ws.Cells(i, "B").Value
End If
ws.Cells(i, "C").Value = grup
Next i
End Sub

[tasad]

Tam istediğim gibi olmasa da işimi görür. Teşekkür ederim.

[erseldemirel]

Kolay gelsin

[halily]

aşağıdaki kodu dener misiniz?
sonuçlar sayfa1'in D ve E sütunlarına yazılıyor

Kod: Tümünü seç

Sub xGrupla()
Set syf = ThisWorkbook.Worksheets("sayfa1")

xGrp = 0
With syf
.UsedRange.Offset(, 2).Cells.Clear
.Range("D1") = "No"
.Range("E1") = "Miktar"
SonStr = .Cells(.Rows.Count, "A").End(xlUp).Row
    For x = 2 To SonStr
        If xGrp + .Range("B" & x) < 26 Then
        SonStrT = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
             xGrp = xGrp + .Range("B" & x)
            .Range("D" & SonStrT) = .Range("A" & x)
            .Range("E" & SonStrT) = .Range("B" & x)
        Else
        SonStrT = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
            .Range("D" & SonStrT) = "Toplam"
            .Range("E" & SonStrT) = xGrp
             xGrp = 0
             xGrp = xGrp + .Range("B" & x)
        SonStrT = .Cells(.Rows.Count, "D").End(xlUp).Row + 2
            .Range("D" & SonStrT) = .Range("A" & x)
            .Range("E" & SonStrT) = .Range("B" & x)
        End If
    Next x
        SonStrT = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
            .Range("D" & SonStrT) = "Toplam"
            .Range("E" & SonStrT) = xGrp
End With
End Sub

[halily]

yada daha hızlı olan dizi yöntemiyle aşağıdaki gibi de yapılabilir ama Application.WorksheetFunction.Transpose fonksiyonu yanılmıyorsam 64 bin satırdan büyüklerde hata verdiğinden bunun üstünde veriler olacaksa transpoze için farklı bir yöntem kullanmak gerekir

Kod: Tümünü seç

Sub xGrupla()
Set syf = ThisWorkbook.Worksheets("sayfa1")


With syf
.UsedRange.Offset(1, 2).Cells.Clear
.Range("D1") = "No"
.Range("E1") = "Miktar"

Dim xDz As Variant
Dim xDzSon As Variant

SonStr = .Cells(.Rows.Count, "A").End(xlUp).Row
xGrp = 0
xDz = .Range("A2:B" & SonStr).Value2
DzBas = LBound(xDz)
DzBit = UBound(xDz)

ReDim xDzSon(1 To 2, 1 To 1)
DzStr = 0
    For x = DzBas To DzBit
    DzStr = DzStr + 1
    ReDim Preserve xDzSon(1 To 2, 1 To DzStr)
        If xGrp + xDz(x, 2) <= 25 Then
        xGrp = xGrp + xDz(x, 2)
            xDzSon(1, DzStr) = xDz(x, 1)
            xDzSon(2, DzStr) = xDz(x, 2)
        Else
            xDzSon(1, DzStr) = "Toplam"
            xDzSon(2, DzStr) = xGrp
             xGrp = 0
             xGrp = xGrp + xDz(x, 2)
        DzStr = DzStr + 2
        ReDim Preserve xDzSon(1 To 2, 1 To DzStr)
            xDzSon(1, DzStr) = xDz(x, 1)
            xDzSon(2, DzStr) = xDz(x, 2)
        End If
    Next x
        DzStr = DzStr + 1
        ReDim Preserve xDzSon(1 To 2, 1 To DzStr)
            xDzSon(1, DzStr) = "Toplam"
            xDzSon(2, DzStr) = xGrp

.Range("D2:E" & UBound(xDzSon, 2) + 1).Value = Application.WorksheetFunction.Transpose(xDzSon)
End With
End Sub

[tasad]

Tam istediğim gibi olmuş, elinize sağlık.
Size ve Ersel hocaya yardımlarınızdan dolayı teşekkür ederim.

[halily]

Rica ederim
İyi çalışmalar