Çoklu Düşeyara Makrosu

[yasin85]

Herkese Merhaba,

Öncelikle şunu belirtmek isterim ki verilen örnekleri denedim fakat yapamadım ve en az 4 saattir uğraşıyorum..

bu konuda yardımlarınızı bekliyorum.

http://s6.dosya.tc/server5/vmdvof/ozet_tablo_coklu_duseyara.xlsx.html

 

[Orion1]

Dosyanız aşağıdaki linktedir.

DOSYAYI İNDİR

Sub benzersiz59()
Dim z As Object, liste(), i As Long, k As Integer, vkey, sat As Long
Dim deg, sut As Integer
Sheets("Sayfa1").Select
sat = 2
liste = Range("A2:E" & Cells(Rows.Count, "B").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        z.Add liste(i, 1), liste(i, 5)
        Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) & "|" & liste(i, 5)
    End If
Next i
Erase liste
Sheets("özet tablo").Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = True
For Each vkey In z.keys
    sut = 2
    Cells(sat, "A").Value = vkey
    deg = Split(z.Item(vkey), "|")
    For k = 0 To UBound(deg)
        Cells(sat, sut).Value = deg(k)
        sut = sut + 1
    Next k
    sat = sat + 1
Next
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[yasin85]

Evren Hocam,

Ellerine sağlık tam istediğim gibi olmuş.. işi ehline bırakmak bu olsa gerek

 

[Orion1]

Evren Hocam,

Ellerine sağlık tam istediğim gibi olmuş.. işi ehline bırakmak bu olsa gerek

Rica ederim.İyi çalışmalar.

 

[Tevfik_Kursun]

Sayın Orion1 Hocam,
Bu makronun yaptığı, aynı sayfadaki örneğin 12000 küsür kişinin içinde varlığı bilinen adı "Aaa Bbbbb" olan 5 öğrencinin bilgilerini mi getiriyor (diyelim numarasını) ?
Saygılarımla

 

[baydeniro]

Teşekkürler, güzel bir konu

 

[Orion1]

Sayın Orion1 Hocam,
Bu makronun yaptığı, aynı sayfadaki örneğin 12000 küsür kişinin içinde varlığı bilinen adı "Aaa Bbbbb" olan 5 öğrencinin bilgilerini mi getiriyor (diyelim numarasını) ?
Saygılarımla

Kaç öğrenci varsa getiriyor,benzersiz olarak.

 

[Tevfik_Kursun]

Sayın Orion! Hocam,
Sanırım başka bir başlıkla açmalıyım düşündüğüm konuyu.
İlginize teşekkür ederim
Saygılarımla

 

[yasin85]

Sn. Evren Hocam,

Aynı liste için bir küçük dokunuş daha isteyeceğim örneği alt linkte yer alıyor yardımlarınızı bekler iyi çalışmalar dilerim..

http://www.dosya.tc/server7/pv5voh/ozet_tablo_coklu_duseyara_2.xlsx.html

 

[Orion1]

Sn. Evren Hocam,

Aynı liste için bir küçük dokunuş daha isteyeceğim örneği alt linkte yer alıyor yardımlarınızı bekler iyi çalışmalar dilerim..

http://www.dosya.tc/server7/pv5voh/ozet_tablo_coklu_duseyara_2.xlsx.html

Dosyanız ektedir.

DOSYAYI İNDİR

Sub benzersiz59()
Dim z As Object, liste(), i As Long, k As Integer, vkey, sat As Long
Dim deg, sut As Integer
Sheets("Sayfa1").Select
sat = 2
liste = Range("A2:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        z.Add liste(i, 1), liste(i, 4) & "|" & liste(i, 3)
        Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) & "|" & liste(i, 4) & "|" & liste(i, 3)
    End If
Next i
Erase liste
Sheets("özet tablo").Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = True
For Each vkey In z.keys
    sut = 2
    Cells(sat, "A").Value = vkey
    deg = Split(z.Item(vkey), "|")
    For k = 0 To UBound(deg)
        Cells(sat, sut).Value = deg(k)
        sut = sut + 1
    Next k
    sat = sat + 1
Next
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[yasin85]

Sn. Evren Hocam,

Tam istediğim gibi olmuş teşekkür ederim..

Bu arada '' Madem biliyorsun neden öğretmiyorsun.Boşa vakit geçirdin neye yaradı. '' bu ata sözünü de sizden gördüm ve kendime küpe yaptım..

Kolay gelsin, iyi çalışmalar

 

[yasin85]

Teşekkürler

 

[Orion1]

Teşekkürler

Rica ederim.
İyi çalışmalar.

 

[baydeniro]

teşekkürler sayın Orion1

 

[Orion1]

teşekkürler sayın Orion1

Rica ederim.
İyi çalışmalar.

 

[guysal]

merhaba bi konuda acil desteğe ihtiyacım var bir veriye karşılık gelen tüm verileri bir dosyaya nasıl toplayabilirim, örneğin bir araca karşılık gelen tüm faturaları bi sayfada nasıl görebilirm

 

[Orion1]

merhaba bi konuda acil desteğe ihtiyacım var bir veriye karşılık gelen tüm verileri bir dosyaya nasıl toplayabilirim, örneğin bir araca karşılık gelen tüm faturaları bi sayfada nasıl görebilirm

Yeni bir konu açarak örnek dosyanızı ekleyerek ve dosya üzerinde açıklama yaparak sorunuzu sorunuz.Buradaki konunun cevabı verilmiş olup konu kapanmıştır.

 

[guysal]

yeni konu açmıştım dosyayı da ekledim

 

[FERAZ]

Dosyanız ektedir.

DOSYAYI İNDİR

Sub benzersiz59()
Dim z As Object, liste(), i As Long, k As Integer, vkey, sat As Long
Dim deg, sut As Integer
Sheets("Sayfa1").Select
sat = 2
liste = Range("A2:D" & Cells(Rows.Count, "B").End(xlUp).Row).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1)) Then
        z.Add liste(i, 1), liste(i, 4) & "|" & liste(i, 3)
        Else
        z.Item(liste(i, 1)) = z.Item(liste(i, 1)) & "|" & liste(i, 4) & "|" & liste(i, 3)
    End If
Next i
Erase liste
Sheets("özet tablo").Select
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Application.ScreenUpdating = True
For Each vkey In z.keys
    sut = 2
    Cells(sat, "A").Value = vkey
    deg = Split(z.Item(vkey), "|")
    For k = 0 To UBound(deg)
        Cells(sat, sut).Value = deg(k)
        sut = sut + 1
    Next k
    sat = sat + 1
Next
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

Application.ScreenUpdating = True bu iki kere yazılmış ilki false olacaktı sanırım gözlerden kaçmış

 

[Orion1]

Application.ScreenUpdating = True bu iki kere yazılmış ilki false olacaktı sanırım gözlerden kaçmış

Evet haklısınız,gözümden kaçmış.Sizin gözünüzden kaçmamış.Tebrik ederim.