Sütun Gruplama

Cevapla
tasad
Mesajlar: 21
Kayıt: Sal Ağu 01, 2023 2:07 pm
Meslek: Muhasebeci
Adınız: tarık
Soyadınız: sadık

Sütun Gruplama

Mesaj gönderen 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
Mesajlar: 77
Kayıt: Cmt Haz 24, 2023 12:23 am
Web Sitesi: https://erseldemirel.com.tr/
Adınız: Ersel
Soyadınız: Demirel

Re: Sütun Gruplama

Mesaj gönderen 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
Mesajlar: 21
Kayıt: Sal Ağu 01, 2023 2:07 pm
Meslek: Muhasebeci
Adınız: tarık
Soyadınız: sadık

Re: Sütun Gruplama

Mesaj gönderen tasad »

Tam istediğim gibi olmasa da işimi görür. Teşekkür ederim.
erseldemirel
Mesajlar: 77
Kayıt: Cmt Haz 24, 2023 12:23 am
Web Sitesi: https://erseldemirel.com.tr/
Adınız: Ersel
Soyadınız: Demirel

Re: Sütun Gruplama

Mesaj gönderen erseldemirel »

Kolay gelsin
halily
Mesajlar: 3
Kayıt: Cmt Haz 24, 2023 8:43 am
Adınız: halil
Soyadınız: yaşar

Re: Sütun Gruplama

Mesaj gönderen 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
Mesajlar: 3
Kayıt: Cmt Haz 24, 2023 8:43 am
Adınız: halil
Soyadınız: yaşar

Re: Sütun Gruplama

Mesaj gönderen 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
Mesajlar: 21
Kayıt: Sal Ağu 01, 2023 2:07 pm
Meslek: Muhasebeci
Adınız: tarık
Soyadınız: sadık

Re: Sütun Gruplama

Mesaj gönderen tasad »

Tam istediğim gibi olmuş, elinize sağlık.
Size ve Ersel hocaya yardımlarınızdan dolayı teşekkür ederim.
halily
Mesajlar: 3
Kayıt: Cmt Haz 24, 2023 8:43 am
Adınız: halil
Soyadınız: yaşar

Re: Sütun Gruplama

Mesaj gönderen halily »

Rica ederim
İyi çalışmalar
Cevapla
  • Benzer Konular
    Cevaplar
    Görüntüleme
    Son mesaj