Birleştirip toplama

[acar6783]

Merhaba

Bir kod var onda duzenleme ıstıyorum yardımcı olabılrısınz
kodda a ve b sutunlarında aynı olanları bırlestırıp adetını de topluyor duzeltme a-b-c sutunlarında olan bılgılerı yıne a ve b birleşecek c ise toplanacak sekılde yapılabılırmı

Sub BensersizListeleTopla()

Dim d, s, a1, a2, deg, i As Integer, son As Long

Set d = CreateObject("Scripting.Dictionary")

Application.ScreenUpdating = False

For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
deg = Cells(i, "A")
If Not d.exists(deg) Then
s = Array(1, Cells(i, "B"))
d.Add deg, s
Else
s = d.Item(deg)
s(1) = s(1) + Cells(i, "B")
d.Item(deg) = s
End If
Next i

a1 = d.keys: a2 = d.items

Range("A2:A" & Rows.Count).ClearContents

For i = 0 To d.Count - 1
Cells(i + 2, "A") = a1(i)
s = a2(i)
Cells(i + 2, "B") = s(1)
Next i

son = Cells(Rows.Count, "A").End(xlUp).Row + 1

Range("B" & son & ":B" & Rows.Count).ClearContents

Set d = Nothing
Application.ScreenUpdating = True

End Sub

 

[Ömer]

Merhaba,

Sorunuzla ilgili küçük bir örnek dosya ekleyip detaylı açıklarmısınız.

 

[acar6783]

dosyam ornek ekledım

 

[Ömer]

Bu şekilde deneyin.

Sub BensersizListeleTopla()
 
    Dim d, s, a1, a2, deg, i As Integer, son As Long
    
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            s = Array(Cells(i, "B"), Cells(i, "C"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(1) = s(1) + Cells(i, "C")
            d.Item(deg) = s
        End If
    Next i
        
    a1 = d.keys: a2 = d.items
    
    Range("D2:F" & Rows.Count).ClearContents
    
    For i = 0 To d.Count - 1
        s = a2(i)
        Cells(i + 2, "D") = a1(i)
        Cells(i + 2, "E") = s(0)
        Cells(i + 2, "F") = s(1)
    Next i
    
    Set d = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

 

[acar6783]

hocam aynı sutunlşarda toplatamazmıyız d-e-f de ayrı olrak yazıyor a-b-c sutunların aynı yerde toplasa olmaz mı ben kodda d-e-f yazan yerı degıstım ama olmadı

 

[Ömer]

hocam aynı sutunlşarda toplatamazmıyız d-e-f de ayrı olrak yazıyor a-b-c sutunların aynı yerde toplasa olmaz mı ben kodda d-e-f yazan yerı degıstım ama olmadı

Ek diziyle de yapılabilirdi fakat veri sayısı fazla olursa limit problemi yaratabilir diye bu şekilde yaptım.

Sub BensersizListeleTopla()
 
    Dim d, s, a1, a2, deg, i As Integer, son As Long
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A")
        If Not d.exists(deg) Then
            s = Array(Cells(i, "B"), Cells(i, "C"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(1) = s(1) + Cells(i, "C")
            d.Item(deg) = s
        End If
    Next i
 
    a1 = d.keys: a2 = d.items
 
    Range("K2:M" & Rows.Count).ClearContents 'Yardımcı sütunlar
    [COLOR=blue]Columns("K:K").NumberFormat = "@"
[/COLOR] 
    For i = 0 To d.Count - 1
        s = a2(i)
        Cells(i + 2, "K") = a1(i)
        Cells(i + 2, "L") = s(0)
        Cells(i + 2, "M") = s(1)
    Next i
 
    Range("A2:C" & Rows.Count).Clear
    Range("K2:M" & i + 3).Copy Range("A2")
    Range("K2:M" & Rows.Count).ClearContents
 
    Set d = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

 

[acar6783]

ellerıne saglık hocam dedıgım buydu ellerıne saglık

 

[acar6783]

ömer bey kodu sayfama ekledım ama bır hata verdı
yardımıc olabılırmsnz
sayfa ıcınde acıklama yaptım

 

[Ömer]

Sayfada kod göremedim. Ayrıca tekrar denedim herhangi bir hata almadım.

 

[acar6783]

sayfayı bıdaha eklyorum ömer bey galiba yanlıs ekledım

a sutunundakılere dıkkat edersenız orjınalı sayfasındakılerı tekrar yoldakıler sayfasına yapıstrdgınzda farkı goreceksınız sayılar degısıyor

 

[Ömer]

Hücre biçimiyle ilgili bir durum. #6 numaralı mesajı düzenledim. Tekrar deneyiniz.

 

[acar6783]

ömer bey yine aynı sekılde oldu virgül koyuyor (4,1111) ama orijinal sayfadaki gibi 0004.1111 (örnek) cıkmıyor

 

[Ömer]

Yeniden düzenledim. #6 numaralı mesajı tekrar deneyiniz.

 

[acar6783]

Ellerine sağlık hocam tesekkur ederım

 

[acar6783]

Ellerine sağlık hocam tesekkur ederım

hocam aynı kodu yeni sayfama uyarlayamadım yardımcı olabilirmisiniz...
asygılar

 

[Ömer]

Eski kodu hesaba katmadan, yeni dosyada yapmak istediğinizi detaylı açıklarmısınız.

 

[acar6783]

ömer hocam
dosyamda acıkladım inşallah anlatabilmişimdir..

 

[acar6783]

hocam yardımcı olabilecekmisiniz.?

 

[Ömer]

Mükerrerlik kontrolünü "a b c e" bu dört sutunda mı yapacak yoksa tek bir sütunda yapıp tüm sütunlarımı aktaracak. Farkı bir sayfada mı listelenecek, formülün içeriği nedir, listeleme yapıldıktan sonra bu formüller yeni listede yine olacak mı?

 

[acar6783]

Mükerrerlik kontrolünü "a b c e" bu dört sutunda mı yapacak yoksa tek bir sütunda yapıp tüm sütunlarımı aktaracak. Farkı bir sayfada mı listelenecek, formülün içeriği nedir, listeleme yapıldıktan sonra bu formüller yeni listede yine olacak mı?

f ve g sutunları sabit kalacak orada değişme olmayacak çünkü f sütunundaki formul asıl dosyadaki sayfa1 de c sütununda yazan kodu arıyor ve adeti neyse onu yazıyor...

mükerrerlik kontrolü ''a b c e '' sütunlarında olacak ve eğer aynı olan var ise adetlerini toplayaran tek satırda birleşecek..

ya da başka bir şekilde de olabilir ... c sütununda yazan kodlara göre mükerrerlik kontrolü de yapılabilir aynı olan kodları bulup birleştirip adetlerini de toplatabiiliriz...