Sütun Gruplama
-
- Mesajlar: 26
- Kayıt: 01 Ağu 2023, 14:07
- Meslek: Muhasebeci
- Adınız: tarık
- Soyadınız: sadık
Sütun Gruplama
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
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
-
- Mesajlar: 84
- Kayıt: 24 Haz 2023, 00:23
- Web Sitesi: https://erseldemirel.com.tr/
- Adınız: Ersel
- Soyadınız: Demirel
Re: Sütun Gruplama
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
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
-
- Mesajlar: 26
- Kayıt: 01 Ağu 2023, 14:07
- Meslek: Muhasebeci
- Adınız: tarık
- Soyadınız: sadık
Re: Sütun Gruplama
Tam istediğim gibi olmasa da işimi görür. Teşekkür ederim.
-
- Mesajlar: 84
- Kayıt: 24 Haz 2023, 00:23
- Web Sitesi: https://erseldemirel.com.tr/
- Adınız: Ersel
- Soyadınız: Demirel
Re: Sütun Gruplama
Kolay gelsin
-
- Mesajlar: 3
- Kayıt: 24 Haz 2023, 08:43
- Adınız: halil
- Soyadınız: yaşar
Re: Sütun Gruplama
aşağıdaki kodu dener misiniz?
sonuçlar sayfa1'in D ve E sütunlarına yazılıyor
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
-
- Mesajlar: 3
- Kayıt: 24 Haz 2023, 08:43
- Adınız: halil
- Soyadınız: yaşar
Re: Sütun Gruplama
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
-
- Mesajlar: 26
- Kayıt: 01 Ağu 2023, 14:07
- Meslek: Muhasebeci
- Adınız: tarık
- Soyadınız: sadık
Re: Sütun Gruplama
Tam istediğim gibi olmuş, elinize sağlık.
Size ve Ersel hocaya yardımlarınızdan dolayı teşekkür ederim.
Size ve Ersel hocaya yardımlarınızdan dolayı teşekkür ederim.
-
- Mesajlar: 3
- Kayıt: 24 Haz 2023, 08:43
- Adınız: halil
- Soyadınız: yaşar
Re: Sütun Gruplama
Rica ederim
İyi çalışmalar
İyi çalışmalar