Tür ve sicile göre en son tarihi bulmak

[tahsinanarat]

Herkese kolay gelsin,

Ekli dosyamda Arşiv ve Rapor adlı iki sekmem var, Arşiv sayfasının B sutunundaki sicil, I sutununda ise Tür Başlığı altında Kıyafet türleri yazılı.
Benim yapmak istediğim Rapor sayfasında E sutunundan balayıp sağa doğru devam eden Türlerden oluşan başlıklarım olacaık. (yerleri değişken olabilir),
Bu başlıkların altına A sutununda bulunan o sicilli kişinin Arşiv sayfasından o ürüne ait en son aldığı tarih gelecek.
Olması gereken ilk iki kişiyi ben manuel olarak yaptım.
Bu konuda hocalarımdan yardım bekliyorum. Şimdiden çok teşekkürler.

Saygılarımla

 

[veyselemre]

Sub adoTransform()
    Dim rs As Object, con$, strSQL$, i
    Sheets("Rapor").Select
    Cells.ClearContents
    Set rs = CreateObject("ADODB.Recordset")
 
    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""
      
    strSQL = "TRANSFORM LAST([TARİH]) " & _
             "SELECT [SİCİL], [ADI VE SOYADI] FROM [Arsiv$A1:I] " & _
             "GROUP BY [ADI VE SOYADI], SİCİL PIVOT [TÜR]"

    rs.Open strSQL, con, 1, 1
 
    Range("A2").CopyFromRecordset rs
    For i = 0 To rs.Fields.Count - 1
        Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i
    With Range("A1").CurrentRegion
        With .Rows(1)
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .Font.Color = vbWhite
            .Interior.Color = 12611584
        End With
        With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
            .HorizontalAlignment = xlCenter
            .NumberFormat = "dd.MM.yyyy"
        End With
        .EntireColumn.AutoFit
    End With
    rs.Close
End Sub

 

[metin80]

=EĞERHATA(MAK(EĞER(Arsiv!$B:$B=Rapor!$A2;EĞER(Arsiv!$I:$I=Rapor!C$1;Arsiv!$A:$A)));"")
c2 hücresine bu formulu yapıştırıp CTRL+ shift+enter tuşuna basınız hücresin altındaki + tuşundan itibaren yana doğru cekin

 

[tahsinanarat]

Sn. @veyselemre Hocam, elinize zihninize sağlık, tam istediğim gibi ve inanılmaz hızlı olmuş, cok teşekkür ediyorum, Sağolun Hocam.

 

[tahsinanarat]

Sn. @veyselemre hocam, şimdi orjinal dosyamda uyguladım, 127 Bin satır, hız aynı ancak, aynı ürünün ilk aldığı tarihini getirdiğini fark ettim, oysa en son aldığı tarihi getirmesi gerekiyor, bu konuda yardımcı olabilirmisiniz. Teşekkürler.

 

[muygun]

Merhaba;
Hazırladığım örnek alternatif olsun.
Eki deneyin.
İyi çalışmalar.

 

[tahsinanarat]

Sn. @muygun 127000 datamda uygulamaya çalışıyorum ancak, döngü halen devam ediyor, sonuç alamıyorum. Bilginiz olsun.

 

[tahsinanarat]

Sn. @veyselemre hocam, birde sanki arşiv sayfasından 127002 satır olmasına rağmen 65557 satırdan aşağısını getirmediğini gözlemledim.

 

[veyselemre]

Verileriniz küçükten büyüğe tarih sıralı olması gerekir. Last komutu en son kaydın tarihini alıyor. Verdiğiniz örnekte sorun çıkmadı. Özet tablo ile de kontrol ettim sonuçları. Last yerine Max kullanarak sorun aşılır, ama 65536 adonun sınırı..

 

[tahsinanarat]

sn. @veyselemre Hocam, Bilgilendirme için çok teşekkürler , sınırın 65536 olmasına üzüldüm, kodlar çok hızlı sonuç üretiyordu, ancak bu durumda bu projede kullanamayacağım, Bu güzel kodu başka bir projede kullanmak üzere arşivime alacağım, Bunun içinde vba kodları ile başka bir çözüm bekliyor olacağım. Sayfılar.

 

[veyselemre]

Çalışıp çalışmayacağı konusunda emin değilim. Çalışmazsa 65536 satırdan fazla satırı olan çalışmanıza uygun bir örnek ekleyin onun üzerinde deneyelim. Ben basit bir select sorgusunda çalıştırdım.

Sub adoUnionAllTransform()
   
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    Dim lr&, lc%, sut%, ySut%, strSQL$
    Dim sName$, sonSat&, say%, sql$(), con$, i%
    Dim rs As Object
   
    Sheets("Arsiv").Copy Before:=Sheets(1)

    lr = Cells(Rows.Count, 1).End(3).Row
    lc = Cells(1, Columns.Count).End(1).Column
    sut = 1
    say = 0

    sName = ActiveSheet.Name & "$"
   
    Do While lr > 1
       
        say = say + 1
        ReDim Preserve sql$(1 To say)
        sonSat = IIf(lr > 65536, 65536, lr)
        sql(say) = " SELECT * FROM [" & sName & Range(Cells(1, sut), Cells(sonSat, sut + lc - 1)).Address(0, 0) & "] "
       
        If lr < 65536 Then Exit Do
        ySut = sut + lc + 1
        Range(Cells(65537, sut), Cells(lr, sut + lc - 1)).Cut Cells(2, ySut)
   
        Range(Cells(1, 1), Cells(1, lc)).Copy Cells(1, ySut)
        lr = Cells(Rows.Count, ySut).End(3).Row
        sut = ySut

    Loop
    
    strSQL = "TRANSFORM MAX([TARİH]) " & _
             "SELECT [SİCİL], [ADI VE SOYADI] FROM ( " & Join(sql, " UNION ALL ") & ") " & _
             "GROUP BY [ADI VE SOYADI], SİCİL PIVOT [TÜR] "

    Set rs = CreateObject("ADODB.Recordset")

    con = "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & ThisWorkbook.FullName & _
          ";Extended Properties=""Excel 12.0;Hdr=YES"""
   
    rs.Open strSQL, con, 1, 1

    With Sheets("Rapor")
        .Cells.ClearContents
        .Range("A2").CopyFromRecordset rs
        For i = 0 To rs.Fields.Count - 1
            .Cells(1, i + 1).Value = rs.Fields(i).Name
        Next i
        With .Range("A1").CurrentRegion
            With .Rows(1)
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .Font.Color = vbWhite
                .Interior.Color = 12611584
            End With
            With .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2)
                .HorizontalAlignment = xlCenter
                .NumberFormat = "dd.MM.yyyy"
            End With
            .EntireColumn.AutoFit
        End With
   
        rs.Close
    End With
   
    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True
   
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[tahsinanarat]

Sn. @veyselemre hocam eklediğim görüntüdeki hata mesajını veriyor, ve hatayı sonlandırıp tıkladığımda Arşiv (1), Arşiv (2) şeklinde Arşiv sayfasını copyalıyor.

 

[Haluk]

Konuyu belki yanlış anlamış olabilirim ama ekli dosyayı dener misiniz?

.

 

[tahsinanarat]

Sn. @Haluk Hocam gerçek datalarım olan 117853 satırlık kayıtda 5601 benzersiz kayıttan 4601 kayıt getirdi, yani tam 1000 kayıt kayıp olarak getirdi, özellikle 11497 ile 15373 sicil arasında toplamda 1000 kayıt eksik var, inceliyorum ama diğer kayıtlardan pek bir fark göremedim.

 

[Haluk]

Tahsin Bey; kodda kayıt sayısıyla ilgili bir kısıtlama yok. Durumu anlayabilmek için üzerinde çalıştığınız dosyayı görmek gerekir. İsterseniz, dosyadaki isimleri değiştirip, buraya ekleyin.... duruma bakalım. Siz bilirsiniz...

.

 

[Korhan Ayhan]

Alternatif...

Daha önce forumda paylaştığım benzer bir kodu sizin dosyanıza göre revize ettim.

Deneyip süreyi bildirirseniz sevinirim.

Option Explicit

Sub Pivot_Table()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Pivot_Cache As PivotCaches, Pivot_Data As Range
    Dim Pivot_Table As PivotTables, Zaman As Double
  
    Zaman = Timer
  
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    Set S1 = Sheets("Arsiv")
    Set S2 = Sheets("Rapor")
  
    S2.Select
    S2.Cells.Delete
  
    Set Pivot_Data = S1.Range("A1").CurrentRegion
  
    If Pivot_Data.Rows.Count = 1 Then
        MsgBox "Sayfada işlem yapılacak veri bulunamadı!", vbCritical
        Exit Sub
    End If
  
    On Error Resume Next
  
    Set Pivot_Cache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=Pivot_Data). _
                      CreatePivotTable(TableDestination:=S2.Range("A1"), TableName:="Pivot_Table1")
  
    Set Pivot_Table = Pivot_Cache.CreatePivotTable(TableDestination:=S2.Range("A1"), TableName:="Pivot_Table1")
  
    On Error GoTo 0

    With S2.PivotTables("Pivot_Table1")
        .PivotFields("SİCİL").Orientation = xlRowField
        .PivotFields("SİCİL").Position = 1
        .PivotFields("SİCİL").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
        .PivotFields("ADI VE SOYADI").Orientation = xlRowField
        .PivotFields("ADI VE SOYADI").Position = 2
        .AddDataField S2.PivotTables("Pivot_Table1").PivotFields("TARİH"), , xlMax
        .PivotFields("TÜR").Orientation = xlColumnField
        .PivotFields("TÜR").Position = 1
        .RepeatAllLabels xlRepeatLabels
        .RowAxisLayout xlTabularRow
        .ColumnGrand = False
        .RowGrand = False
    End With
  
    With S2.Range("A1").CurrentRegion
        .Offset(1).Copy: S2.Range("A1").PasteSpecial xlPasteValues
         Application.CutCopyMode = False
        .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2).Select
        .Rows(1).Interior.Color = 7884319
        .Rows(1).Font.Color = vbWhite
        .Rows(1).Font.Bold = True
        .Rows(1).HorizontalAlignment = xlCenter
        .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2).NumberFormat = "dd.mm.yyyy"
    End With

    S2.Range("B2").Select
    S2.Columns.AutoFit
  
    Set S1 = Nothing
    Set S2 = Nothing
    Set Pivot_Data = Nothing
    Set Pivot_Cache = Nothing
    Set Pivot_Table = Nothing
  
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrlf & _
           "İşlem süresi ; " & Format((Timer - Zaman), "0.00") & " Saniye"
End Sub

 

[veyselemre]

strSQL = "TRANSFORM MAX([TARİH]) " & _
             strSQL = "SELECT [SİCİL], [ADI VE SOYADI] FROM ( " & Join(sql, " UNION ALL ") & ") " & _
             "GROUP BY [ADI VE SOYADI], SİCİL PIVOT [TÜR] "

Bu kısımda 2 satırda strSQL = silinecek. Veri sayısı az olduğu için sadece select sorgusunda denenmişti. Düzenlerken o kısım unutulmuş.

    strSQL = "TRANSFORM MAX([TARİH]) " & _
             "SELECT [SİCİL], [ADI VE SOYADI] FROM ( " & Join(sql, " UNION ALL ") & ") " & _
             "GROUP BY [ADI VE SOYADI], SİCİL PIVOT [TÜR] "

Bu şekilde deneyin.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam, orjinal dosyam da çalıştırdım, 2.20 saniyede tamamladı, ancak mükerrer kayıtların gelmemesi adına sorguyu sadece sicil üzerinden yapabilir miyiz, sicili aynı olup daha sonrada soyisim değişikliği yapanlar iki farklı kişiymiş gibi geliyor.
Arşiv Sayfasının Başlık Satırını tarih aralığına güncellemem gerektiğinden 5.Sutundan yapmıştım, kodu buna göre revize edebilirmiyiz. Ben S1 deki A1 i A5 olarak değiştirdim ama olmadı.
Birde Arşiv sayfasının Tabloya dönüştürmem gerektiğini sanıyorum, doğrumu?

Sn. @veyselemre Hocam sizin dediklerinizi de deneyip sonucu bildireceğim.

 

[tahsinanarat]

Sn. @veyselemre hocam, sizin kodlarınızı da denedim, Korhan hocamla aynı sonucu 2.39 sn de veriyor (sicili aynı olup soyadı farklı olanlar dahil), saadece sicil üzerinden denedim mükerrer olanlar gelmiyor ancak ADI VE SOYADI sutunu boş kalıyor. Emekleriniz için çok teşekkür ediyorum. İyi hafta sonları diliyorum.

 

[Korhan Ayhan]

Bahsettiğini değişiklik için dosyanıza benzer (satır-sütun bakımından) örnek dosya paylaşırsanız kodu revize edebilirim.

Ayrıca son mesajınızda sadece sicil üzerinden sorgu yapıldığında farklı isimlerin nasıl görünmesini bekliyorsunuz? Bunu da örneklendirmeniz gerekir.