Grupla ve toplam al

[hakankilic]

Kolay gelsin. Nevşehir ilinde Astsubay olarak çalışıyorum. Siteniz içinde bulduğum bir programda uğraştım. Bir yere kadar da yaptım. Ancak ekli dosyada da görüneceği üzere İSTENİLEN isimli sayfadaki durumu başaramadım. İSTENİLEN isimli sayfadaki gibi sıralayıp gruplayıp toplam almasını istiyorum. Bu konuda bana yardımcı olurmusunuz? Teşekkür ederim.

 

[muygun]

Merhaba;
Eki inceleyin.
İyi çalışmalar.

 

[halit3]

Alternatif dosya

Sub Gruplandir2()

Set s1 = Sheets("Sayfa1") ' veri sayfası
Set s2 = Sheets("Sayfa2") 'aktarılan sayfa

s2.Range("a1:c" & Rows.Count).ClearContents
sat1 = 1

s2.Range("a1:c" & Rows.Count).Borders(xlDiagonalDown).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlDiagonalUp).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlEdgeLeft).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlEdgeTop).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlEdgeBottom).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlEdgeRight).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlInsideVertical).LineStyle = xlNone
s2.Range("a1:c" & Rows.Count).Borders(xlInsideHorizontal).LineStyle = xlNone

s2.Cells(sat1, 1).Value = "GURUBU"
s2.Cells(sat1, 2).Value = "GRUP ÜYESİ"
s2.Cells(sat1, 3).Value = "ÜCERETİ"

s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeLeft).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeTop).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeBottom).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeRight).LineStyle = xlContinuous


sat1 = sat1 + 1
son1 = s1.Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1):

For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(s1.Cells(j, "c"))
ara2(j) = 1
Next j

sat1 = sat1 + 1

For r = 2 To son1
aranan1 = ara1(r)

sut2 = 0
If ara2(r) = 1 Then

For i = r To son1
If ara1(i) = aranan1 Then
sut2 = sut2 + CDbl(s1.Cells(i, "b").Value)
ara2(i) = 0
s2.Cells(sat1, 1).Value = s1.Cells(i, "c").Value
s2.Cells(sat1, 3).Value = s1.Cells(i, "b").Value
s2.Cells(sat1, 2).Value = s1.Cells(i, "a").Value

s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeLeft).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeTop).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeBottom).LineStyle = xlContinuous
s2.Range("a" & sat1 & ":c" & sat1).Borders(xlEdgeRight).LineStyle = xlContinuous

sat1 = sat1 + 1
End If
Next i

s2.Cells(sat1, 2).Value = "TOPLAM"
s2.Cells(sat1, 3).Value = sut2
s2.Range("b" & sat1 & ":c" & sat1).Borders(xlEdgeLeft).LineStyle = xlContinuous
s2.Range("b" & sat1 & ":c" & sat1).Borders(xlEdgeTop).LineStyle = xlContinuous
s2.Range("b" & sat1 & ":c" & sat1).Borders(xlEdgeBottom).LineStyle = xlContinuous
s2.Range("b" & sat1 & ":c" & sat1).Borders(xlEdgeRight).LineStyle = xlContinuous
sat1 = sat1 + 2

End If
Next r

MsgBox "İşleminiz tamamlanmıştır."

End Sub

 

[hakankilic]

Teşekkür ederim. Elinize emeğinize sağlık. Tam istediğim gibi olmuş.

 

[Erdem Akdemir]

Merhaba,

Özet tablo kullanmanızı tavsiye ederim.
Çok pratik ve hızlıdır.