• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Benzersiz al ve topla

J

jajiyiko

Katılım
29 Mart 2005
Mesajlar
84
Excel Vers. ve Dili
excel 2003
Merhaba!

Herkese kolay gelsin.

Sayfa1 de ;

TÜR MARKASI GELİŞ TARİHİ MİKTARI TUTARI
==== ====== ========= ====== =====
A XX XXXXXXXX 100 1250
D XX XXXXXXXX 200 2500
A XX XXXXXXX 50 60
C XX XXXXXXXX 220 1500
B XX XXXXXXXX 100 1250
D XX XXXXXXXX 200 2500
A XX XXXXXXX 50 60
C XX XXXXXXXX 220 1500

binlerce kayıt var.
Aşağıdaki kod ( ki bu siteden bulmuştum ) ile ;
"TÜR" sütununa göre benzesizleri alabildim. Ancak aşağıdaki gibi toplam alamadım. Nasıl yapabilirim?
Şimdiden teşekkürler.

TÜR MARKASI GELİŞ TARİHİ MİKTARI TUTARI
==== ====== ========= ====== =====
A XX XXXXX 200 1370
B XX XXXXX 100 1250
C XX XXXXX 440 3000
D XX XXXXX 400 5000


Sub TUR_AL_TOPLA()

Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
Dim S2 As Worksheet: Set S2 = Sheets("Sayfa2")

Dim dic As Object, liste(), dizi(), dizi2(), dizi3(), dizi4()

SON = S1.Cells(Rows.Count, "G").End(3).Row
liste = S1.Range("G2:J" & SON).Value

ReDim dizi(1 To SON, 1 To 3)
Set dic = CreateObject("scripting.dictionary")

For x = 1 To UBound(liste, 1)
aranan = liste(x, 1)

If Not dic.exists(aranan) Then
n = n + 1
dic.Add aranan, n
ReDim Preserve dizi(1 To SON, 1 To 3)
dizi(n, 1) = liste(x, 1)
dizi(n, 2) = liste(x, 2)
dizi(n, 3) = liste(x, 3)
End If


Next x

S2.Range("B2:D" & Rows.Count).ClearContents
S2.Range("B2").Resize(dic.Count, 3) = dizi
MsgBox "İşlem Tamam..."
End Sub
 
Örnek dosya eklerseniz daha çabuk cevap alabilirsiniz.:cool:
 
Bu kodu bir dene

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual

Set S1 = Sheets("Sayfa1") ' veri sayfası
Set S2 = Sheets("Sayfa2") 'aktarılan sayfa

S2.Range("A2:j" & Rows.Count).Font.Bold = False
S2.Range("A2:j" & Rows.Count).ClearContents

son1 = S1.Cells(Rows.Count, "c").End(3).Row
ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1):
say = 1
For j = 2 To son1
say = say + 1
ara1(say) = WorksheetFunction.Trim(S1.Cells(j, "c")) & WorksheetFunction.Trim(S1.Cells(j, "b"))
ara2(say) = 1

Next j
sat1 = 2
sat2 = 2

For r = 2 To say
aranan1 = ara1(r)
If ara2(r) = 1 Then

sut8 = 0
sut10 = 0

For i = 2 To say
If ara1(i) = aranan1 Then
ara2(i) = 0
sut8 = sut8 + S1.Cells(i, 8).Value
sut10 = sut10 + S1.Cells(i, 10).Value

End If
Next i
If sat1 > 2 Then
If S2.Cells(sat1 - 1, 3).Value <> S1.Cells(r, 3).Value Then
deg = S2.Cells(sat1 - 1, 3).Value
sat1 = sat1 + 3
son2 = S2.Cells(Rows.Count, "h").End(3).Row

S2.Cells(sat1 - 2, 3).Value = deg & " TOPLAMI"
S2.Cells(sat1 - 2, 8).Value = WorksheetFunction.Sum(S2.Range("h" & sat2 & ":h" & son2))
S2.Cells(sat1 - 2, 10).Value = WorksheetFunction.Sum(S2.Range("j" & sat2 & ":j" & son2))

S2.Cells(sat1 - 2, 3).Font.Bold = True
S2.Cells(sat1 - 2, 8).Font.Bold = True
S2.Cells(sat1 - 2, 10).Font.Bold = True
sat2 = sat1

End If
End If


S2.Cells(sat1, 2).Value = S1.Cells(r, 2).Value
S2.Cells(sat1, 3).Value = S1.Cells(r, 3).Value
S2.Cells(sat1, 4).Value = S1.Cells(r, 4).Value
S2.Cells(sat1, 5).Value = S1.Cells(r, 5).Value
S2.Cells(sat1, 6).Value = S1.Cells(r, 6).Value
S2.Cells(sat1, 7).Value = S1.Cells(r, 7).Value
S2.Cells(sat1, 8).Value = sut8
S2.Cells(sat1, 9).Value = S1.Cells(r, 9).Value
S2.Cells(sat1, 10).Value = sut10

sat1 = sat1 + 1
End If

Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub
 
Sayın halit3!

Öncelikle geç cevapladığım için özür dilerim.

Elinize sağlık. İstediğim gibi olmuş. Çok sağ olun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst