• DİKKAT

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

Çoklu Düşeyara Makrosu

Dosyanız aşağıdaki linktedir.:cool:

DOSYAYI İNDİR

Kod: 
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
 
Evren Hocam,

Ellerine sağlık tam istediğim gibi olmuş.. işi ehline bırakmak bu olsa gerek :)
 
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
 
Tevfik_Kursun' Alıntı:
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
Genişletmek için tıkla ...

Kaç öğrenci varsa getiriyor,benzersiz olarak.:cool:
 
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' Alıntı:
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
Genişletmek için tıkla ...

Dosyanız ektedir.:cool:

DOSYAYI İNDİR

Kod: 
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
 

Ekli dosyalar

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
 
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
 
guysal' Alıntı:
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
Genişletmek için tıkla ...

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.:cool:
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:

DOSYAYI İNDİR

Kod: 
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
Genişletmek için tıkla ...

Application.ScreenUpdating = True bu iki kere yazılmış ilki false olacaktı sanırım gözlerden kaçmış :)
 
FERAZ' Alıntı:
Application.ScreenUpdating = True bu iki kere yazılmış ilki false olacaktı sanırım gözlerden kaçmış :)
Genişletmek için tıkla ...
Evet haklısınız,gözümden kaçmış.Sizin gözünüzden kaçmamış.Tebrik ederim.:cool:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst