Tarih Bazlı Veri Aktarımı Makrosu

[gertt]

Merhaba.
Yukarıda açıklamaya çalıştığım konu hakkında yardımcı olabilir misiniz?
Teşekkürler...

 

[snx111]

örnek dosya yüklermisin

 

[gertt]

Dosyayı gönderdim.

 

[gertt]

Yardımcı olabilecek arkadaş var mı?

 

[snx111]

tarihteki ay ve yıl bölümleri sabitmi
3 cü aya ait veriler sabitmi 4 cü 5 ci aylar olacakmı içinde

 

[gertt]

Tarihteki ay ve yıllar bölümleri sabit değil.Yani tarih sütunu değişken...

 

[snx111]

işin içinde tarih olması işi çok zorluyor

yıl sabit olursa ve ay sabit olursa sadece günler ve puan ve süre arasında sıralama yaptırabilirim
tarihi işe katınca işin içinden çıkılması zor görünüyor

 

[snx111]

xxx ustalar niye bakmıyorlar ?

 

[gertt]

Sayın snx111 ilginiz için teşekkür ederim.Herhalde bir çözüm bulunamayacak.

 

[snx111]

makro kaydete basıp yapmak istediklerini elle yapıp . sonra kaydettiğin makroda ilgili yerleri değiştirerek sorunu çözebilirsin . filtre ile başla istersen gertt

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Sub AKTAR()
    Dim X As Long, Satır As Long, Y_PUAN As Long, M_SÜRE As Long, Aranan As String, Son As Long
    Dim Formul_1 As String, Formul_2 As String, Formul_3 As String
    
    Application.ScreenUpdating = False
    
    Range("F2:I" & Rows.Count).ClearContents
    Satır = 2
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For X = 2 To Cells(Rows.Count, "D").End(3).Row
        If WorksheetFunction.CountIf(Range("I:I"), Cells(X, "D")) = 0 Then
            Formul_1 = "=MAX(IF(D2:D10000=D" & X & ",B2:B10000))"
            Formul_1 = Replace(Formul_1, 10000, Son)
            Y_PUAN = Evaluate(Formul_1)
            
            Formul_2 = "=MIN(IF(D2:D10000=D" & X & ",IF(B2:B10000=" & Y_PUAN & ",C2:C10000)))"
            Formul_2 = Replace(Formul_2, 10000, Son)
            M_SÜRE = Evaluate(Formul_2)
            
            Aranan = Y_PUAN & M_SÜRE & CLng(Cells(X, "D"))
            
            Formul_3 = "=INDEX($A$2:$D$10000,SUMPRODUCT(MATCH(""" & Aranan & """,B2:B10000&C2:C10000&D2:D10000,0)),1)"
            Formul_3 = Replace(Formul_3, 10000, Son)
            Cells(Satır, "F") = Evaluate(Formul_3)
            
            Formul_3 = "=INDEX($A$2:$D$10000,SUMPRODUCT(MATCH(""" & Aranan & """,B2:B10000&C2:C10000&D2:D10000,0)),2)"
            Formul_3 = Replace(Formul_3, 10000, Son)
            Cells(Satır, "G") = Evaluate(Formul_3)
            
            Formul_3 = "=INDEX($A$2:$D$10000,SUMPRODUCT(MATCH(""" & Aranan & """,B2:B10000&C2:C10000&D2:D10000,0)),3)"
            Formul_3 = Replace(Formul_3, 10000, Son)
            Cells(Satır, "H") = Evaluate(Formul_3)
            
            Formul_3 = "=INDEX($A$2:$D$10000,SUMPRODUCT(MATCH(""" & Aranan & """,B2:B10000&C2:C10000&D2:D10000,0)),4)"
            Formul_3 = Replace(Formul_3, 10000, Son)
            Cells(Satır, "I") = Evaluate(Formul_3)
            
            Satır = Satır + 1
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[gertt]

Korhan Bey,merhaba.Yazmış olduğunuz kod mükemmel çalışıyor.Çok ama çok teşekkür ederim.Elinize ve zihninize sağlık.
Sayın snx111 size de çok teşekkür ederim.