Veri Al, Sayıya Göre, Tarih Sırala

[1Al2Ver]

Merhaba,

Sayılara ait tarihleri, büyükten küçüğe ve sütunlara almak istiyorum.

Geniş açıklama ve verileri, ek'li dosyada açıkladım.

Tercihen makro arzuluyorum, düğmeye bağlı veya düğmesiz olabilir.

Teşekkür ederim.

 

[veyselemre]

Sub Resim2_Tıkla()
    Range("G2:U" & Rows.Count).ClearContents
    lst = Range("B2:C" & Cells(Rows.Count, 2).End(3).Row).Value2

    With CreateObject("Scripting.Dictionary")

        For i = LBound(lst) To UBound(lst)
            x0 = .Item(lst(i, 1) & "|" & lst(i, 2))
        Next i
        lst = .keys
        For i = LBound(lst) To UBound(lst)
            ver = Split(lst(i), "|")
            Key = ver(0)
            If .exists(Key) Then
                .Item(Key) = .Item(Key) & "|" & ver(1)
            Else
                .Item(Key) = ver(1)
            End If
        Next i

        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            Key = Trim(Cells(i, "F").Value)
            If .exists(Key) Then
                ver = Split(.Item(Key), "|")
                If UBound(ver) > 0 Then
                    Call sirala(ver)
                    For ii = LBound(ver) To UBound(ver)
                        Cells(i, ii + 7).Value = ver(ii)
                    Next ii
                Else
                    Cells(i, "G").Value = ver(0)
                End If
            End If
        Next i
    End With
End Sub
Sub sirala(ver)
    For i = LBound(ver) To UBound(ver) - 1
    For ii = i + 1 To UBound(ver)
            If ver(i) > ver(ii) Then
                tmp = ver(i)
                ver(i) = ver(ii)
                ver(ii) = tmp
            End If
    Next ii, i
End Sub

 

[1Al2Ver]

Sayın veyselemre merhaba,

Kod sorunsuz çalışıyor, zahmetiniz ve ilginiz için teşekkür ederim.

Kod'un 4 dakikaya yakın bir çalışması oldu, acaba benim PC mi yavaş ?

Siz de bu süre ne kadardı acaba ?

Saygılarımla.

 

[Vedat Özer]

Merhabalar,


Bende saniyeler içinde listeledi

Bende uğraşmıştım fakat yapamamıştım. Teşekkürler Veyselemre:hey:



İ5 8 Gb

 

[veyselemre]

Sayın veyselemre merhaba,

Kod sorunsuz çalışıyor, zahmetiniz ve ilginiz için teşekkür ederim.

Kod'un 4 dakikaya yakın bir çalışması oldu, acaba benim PC mi yavaş ?

Siz de bu süre ne kadardı acaba ?

Saygılarımla.

Gönderdiğiniz örnekte tuşa basmadan bitiyor. Sayfanızda fonksiyon, koşullu biçimlendirme, Worksheet_SelectionChange, Worksheet_Change vs sayfa kontrol kodları ne kadar çok kullanılıyorsa çalışmanız o kadar yavaşlıyor, veri sayısının büyük olduğu durumlarda bu saydıklarımı kullanmamaya çalışın, ben şahsen çok mecbur kalmadıkça hiçbirini kullanmıyorum.

Sub Resim2_Tıkla()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Range("G2:U" & Rows.Count).ClearContents
    lst = Range("B2:C" & Cells(Rows.Count, 2).End(3).Row).Value2

    With CreateObject("Scripting.Dictionary")

        For i = LBound(lst) To UBound(lst)
            x0 = .Item(lst(i, 1) & "|" & lst(i, 2))
        Next i
        lst = .keys
        .RemoveAll
        For i = LBound(lst) To UBound(lst)
            ver = Split(lst(i), "|")
            Key = ver(0)
            If .exists(Key) Then
                .Item(Key) = .Item(Key) & "|" & ver(1)
            Else
                .Item(Key) = ver(1)
            End If
        Next i

        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            Key = Trim(Cells(i, "F").Value)
            If .exists(Key) Then
                ver = Split(.Item(Key), "|")
                If UBound(ver) > 0 Then
                    Call sirala(ver)
                    For ii = LBound(ver) To UBound(ver)
                        Cells(i, ii + 7).Value = ver(ii)
                    Next ii
                Else
                    Cells(i, "G").Value = ver(0)
                End If
            End If
        Next i
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Sub sirala(ver)
    For i = LBound(ver) To UBound(ver) - 1
        For ii = i + 1 To UBound(ver)
            If ver(i) > ver(ii) Then
                tmp = ver(i)
                ver(i) = ver(ii)
                ver(ii) = tmp
            End If
    Next ii, i
End Sub

 

[1Al2Ver]

Gönderdiğiniz örnekte tuşa basmadan bitiyor. Sayfanızda fonksiyon, koşullu biçimlendirme, Worksheet_SelectionChange, Worksheet_Change vs sayfa kontrol kodları ne kadar çok kullanılıyorsa çalışmanız o kadar yavaşlıyor, veri sayısının büyük olduğu durumlarda bu saydıklarımı kullanmamaya çalışın, ben şahsen çok mecbur kalmadıkça hiçbirini kullanmıyorum.

Sayın veyselemre, merhaba,

Çok teşekkür ederim, benim için zahmete katlandınız, hem de 2 defa.Sağolun.

Son kodu kopyaladım ve hemen sonuç aldım.

Bir kez daha teşekkür ederim.

Saygılarımla.