Sayfadaki veriler içerisinden aynı olanları toplayıp aynı sayfanın altına yazmak

[mücahitayan]

Merhaba arkadaşlar

şöyle birşey istesem acaba yapabilir miyiz?

Aynı sayfa içerisindeki benzer isimler toplanıpta yine aynı sayfanın en son boş satırına ekleyecek fakat bunu yaparken bir yandanda topladığı verilerin satırlarını silecek

işlemin bir butona tıklayınca başlamasını istiyorum.

Dosya ekte ilginiz için teşekkür ederim

 

[Necdet]

Merhaba,

Ne makroya ne fonksiyonlara gerek yok bence. Özet tablo işinizi görür.
Excel dersanesinde konu ile bilgileri bulabilirsiniz.

 

[Orion1]

Merhaba arkadaşlar

şöyle birşey istesem acaba yapabilir miyiz?

Aynı sayfa içerisindeki benzer isimler toplanıpta yine aynı sayfanın en son boş satırına ekleyecek fakat bunu yaparken bir yandanda topladığı verilerin satırlarını silecek

işlemin bir butona tıklayınca başlamasını istiyorum.

Dosya ekte ilginiz için teşekkür ederim

Dosyanız ektedir.

Sub mukerrer()
Dim z As Object, i As Long, col As Collection, deg As String
Set z = CreateObject("Scripting.Dictionary")
Set col = New Collection
Sheets("Sayfa3").Select
For i = 2 To Cells(65536, "B").End(xlUp).Row
    deg = UCase(Replace(Replace(Cells(i, "B").Value, "ı", "I"), "i", "İ"))
    If Not z.exists(deg) Then
        z.Add deg, Cells(i, "C").Value
        Else
        z.Item(deg) = z.Item(deg) + Cells(i, "C").Value
    End If
Next i
Application.ScreenUpdating = False
Range("A2:C65536").ClearContents
Range("B2").Resize(z.Count, 2) = Application.Transpose(Array(z.keys, z.items))
For i = 2 To Cells(65536, "B").End(xlUp).Row
    Cells(i, "A").Value = i - 1
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & vbLf & "evrengizlen@hotmail.com", vbOKCancel + vbInformation, "E V R E N"
End Sub

 

[mücahitayan]

Sevgili necdet bey benim var olan bir programım var ve ona uydurmaya çalışyorum yani excele geçiş yaparsam programı kullanamam. Yinede bilgi verdiğiniz için çok teşekkür ederim.

 

[Orion1]

3 numaralı mesajı inceledinizmi?.

 

[N.Ziya Hiçdurmaz]

yanıt

Benim hazırladığımda boşa gitmesin

Sub ozettopla()
Dim sat, sat1, sat2, s As Long
[g5:ı1000] = Empty
s = 9
    For sat = 2 To Cells(65536, "b").End(xlUp).Row
        If WorksheetFunction.CountIf(Range("b2:B" & sat), Cells(sat, "b")) > 1 Then
            Range(Cells(s, "g"), Cells(s, "h")) = Range(Cells(sat, "a"), Cells(sat, "b")).Value
            s = s + 1
        End If
    Next
        For sat1 = 2 To Cells(65536, "b").End(xlUp).Row
        For sat2 = 2 To Cells(65536, "h").End(xlUp).Row
            If Cells(sat1, "b") Like Cells(sat2, "h") Then
                Cells(sat2, "ı") = Cells(sat2, "ı") + Cells(sat1, "c")
            End If
        Next: Next
End Sub

 

[mücahitayan]

3 numaralı mesajı inceledinizmi?.

sevgili evren hocam tam iş çıkış saatime denk geldi. şimdi evimde inceledim. tam verdiğim şekilde olmuş. aslında ben onu kendi sistemime uyarlarım diye düşündüm. fakat yapamadım. tam olarak dosyamı göndersem o formata uydurabilir miyiz.? açıkcası UCASE felan varya kodun içinde onları tam anlayamadım. tabi anlatmanızı istemiycem sizi uğraştırmassam eğer bu sayfaya uyarlayabilir miyiz.

şimdiden çok teşekkür ederim.

 

[Orion1]

sevgili evren hocam tam iş çıkış saatime denk geldi. şimdi evimde inceledim. tam verdiğim şekilde olmuş. aslında ben onu kendi sistemime uyarlarım diye düşündüm. fakat yapamadım. tam olarak dosyamı göndersem o formata uydurabilir miyiz.? açıkcası UCASE felan varya kodun içinde onları tam anlayamadım. tabi anlatmanızı istemiycem sizi uğraştırmassam eğer bu sayfaya uyarlayabilir miyiz.

şimdiden çok teşekkür ederim.

Hangi sütun sorgulanacak.C sütunumu(ADI) ?

 

[mücahitayan]

evet hocam c sütunu

 

[Orion1]

Dosyanız ektedir.

Sub mukerrer()
Dim z As Object, n As Long, i As Long, deg As String, myarr() As Variant
Dim sat As Long, k As Byte
Sheets("RAPORLAMA").Select
sat = Cells(65536, "C").End(xlUp).Row
If sat < 3 Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To sat, 1 To 14)
For i = 3 To sat
    deg = UCase(Replace(Replace(Cells(i, "C").Value, "ı", "I"), "i", "İ"))
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
    End If
    For k = 1 To 12
        myarr(z.Item(deg), k) = Cells(i, k).Value
    Next k
    myarr(z.Item(deg), 13) = myarr(z.Item(deg), 13) + Cells(i, 13).Value
    myarr(z.Item(deg), 14) = myarr(z.Item(deg), 14) + Cells(i, 14).Value
Next i
Application.ScreenUpdating = False
Range("A3:M" & sat).ClearContents
Range("A3").Resize(n, 14) = myarr
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & vbLf & "evrengizlen@hotmail.com", vbOKOnly, "E V R E N"
End Sub

 

[mücahitayan]

sevgili evren çok teşekkür ederim. ellerine sağlık.

 

[Orion1]

sevgili evren çok teşekkür ederim. ellerine sağlık.

Rica ederim.
İyi çalışmalar.

 

[mücahitayan]

SEVGİLİ EVREN HOCAM DOSYADA SANIRIM BİR SORUN VAR :s NE YAZIK Kİ TOPLAMIYOR. ACABA NEDEN OLABİLİR.

 

[mücahitayan]

Tamam tamam o sorunu hallettim row numaraları birer fazla olmuş onları düşürdüm oldu. Tekrar tekrar çok teşekkür ederim.