Sheet 1 ve Sheet 2 Süzme İşlemi.!

_GÜRCAN_ · 25 Eylül 2012

Merhabalar, Sheet 1 ve Sheet 2 deki ''C'' sütununda kimlik nosuna göre, ''AK'' toplam sütununda satırların toplamları 5.000 tl ve üzeri olan kişilerin Sheet 3 sayfanına formül yada makro yardımı ile nasıl aktarabilirim.! Sheetlerin satır aralığı 65536 adettir. Yardım edebilecek arkadaşlara şimdiden teşekkür ederim.
iyi çalışmalar.

Not: Örnek dosya ektedir.

RaMeLoT · 25 Eylül 2012

BA-BS için galiba...
özet tablo grafik raporu oluştur, işini çözebilir...Ama tek sayfada etkili olur. Bi şekilde birleştirilebilirse..

_GÜRCAN_ · 25 Eylül 2012

RaMeLoT' Alıntı:
BA-BS için galiba...
özet tablo grafik raporu oluştur, işini çözebilir...Ama tek sayfada etkili olur. Bi şekilde birleştirilebilirse..

Merhaba özet tablo grafikte uygulanmıyor birden çok farklı karakter barınıyor hatası veriyor.!

Formül veya Makro daha çok işime yarayacağını umuyorum. Yardım edenlerin örnek tablo eklemesini rica ederim.

teşekkürler.

sakman26 · 25 Eylül 2012

Merhaba,

Eki inceleyiniz...

Kolay gelsin...

_GÜRCAN_ · 25 Eylül 2012

sakman26' Alıntı:
Merhaba,

Eki inceleyiniz...

Kolay gelsin...

Merhaba, sakman26 yapmış olduğunuz formül güzel fakat istediğimi vermiyor.!

Sheet 3'te gösterdiğim tablo olması gereken sonucu belirtiyor.

iyi çalışmalar dilerim.

_GÜRCAN_ · 25 Eylül 2012

Ustalardan konuya cevap bekliyorum.

iyi çalışmalar.

sakman26 · 25 Eylül 2012

merhaba,

sanırım istediğiniz liste ek teki gibidir...

kolay gelsin..

Not : 2007 versiyonda hazırlanmıştır...

RaMeLoT · 25 Eylül 2012

üstad ellerine sağlık süper olmuş, galiba arkadaşın istediği gibi. Meraklı biri olarak formüllere bakıyorum da beni aşıyor.

RaMeLoT · 25 Eylül 2012

Ufak bişey de ben hazırladım üstadın formülleri kullanarak. Belki farklı amaçla kullanırsın madem Çorludansın.

_GÜRCAN_ · 26 Eylül 2012

RaMeLoT' Alıntı:
Ufak bişey de ben hazırladım üstadın formülleri kullanarak. Belki farklı amaçla kullanırsın madem Çorludansın.

RaMeLot merhaba dosyanız hata veriyor indiremiyorum. :frown:

sakman26' Alıntı:
merhaba,

sanırım istediğiniz liste ek teki gibidir...

kolay gelsin..

Not : 2007 versiyonda hazırlanmıştır...

merhabalar, Ben 2003 versiyonu kullanıyorum dosyanızı açamıyorum.. :frown:

RaMeLoT · 26 Eylül 2012

_GÜRCAN_' Alıntı:
RaMeLot merhaba dosyanız hata veriyor indiremiyorum. :frown:

merhabalar, Ben 2003 versiyonu kullanıyorum dosyanızı açamıyorum.. :frown:

Gürcan Bey, sakman üstadın dosyası bende (2003te) açılıyor ofiste ama formüllerde hata veriyor. Dün gece 2010 da öyle sıkıntısı yoktu tam senin istediğin tarzdaydı. 2007 to 2003 Dönüştürücü sıkıntı yaratıyor formüllerde galiba...

Benim dosya senin istediğin tarzda değil bilgin olsun tekrardan yükledim. gerekirse mailine de atarım.

_GÜRCAN_ · 26 Eylül 2012

RaMeLoT' Alıntı:
Gürcan Bey, sakman üstadın dosyası bende (2003te) açılıyor ofiste ama formüllerde hata veriyor. Dün gece 2010 da öyle sıkıntısı yoktu tam senin istediğin tarzdaydı. 2007 to 2003 Dönüştürücü sıkıntı yaratıyor formüllerde galiba...

Benim dosya senin istediğin tarzda değil bilgin olsun tekrardan yükledim. gerekirse mailine de atarım.

Sezai Bey, dosya boyutu fazla olduğu için indirme hatası veriyor.

{The file "Gürcan sezai.rar" has been blocked. The file is larger than the configured file size limit.}

_GÜRCAN_ · 26 Eylül 2012

Merhabalar, 7. mesaj dosyasını 2003'e çevirecek ustalar arıyorum.

iyi çalışmalar dilerim.

sakman26 · 26 Eylül 2012

merhaba,

2003 versiyonunda tanınmayan formülü , 2003 versiyonunun tanıyacağı bir şekile getirerek dosyayı yeniden yapmaya çalıştım.Başka aksaklıklar çıkar mı bilmiyorum.
Siz eki inceleyin...

Kolay gelsin...

Korhan Ayhan · 26 Eylül 2012

Merhaba,

Verilerinizin 65.000 satır olduğunu belirtmişsiniz. Bu sebeple size makrolu çözüm öneriyorum. Ekteki örnek dosyadaki butona tıklayıp sonucu gözlemleyin. İşlem süresi konusunda da bilgi verirseniz sevinirim.

Ben ilk iki sayfada 20.000 kayıt oluşturarak denedim. Benim bilgisayarımda yaklaşık 20 saniyede işlem tamamlanıyor.

Not: Listelenecek kayıt sayısı 65.536 sayısını aşarsa kod hata verir. Eğer böyle bir durum varsa yeni sayfa ekleyerek listeleme yapmak gerekecektir.

_GÜRCAN_ · 27 Eylül 2012

Korhan Ayhan' Alıntı:
Merhaba,

Verilerinizin 65.000 satır olduğunu belirtmişsiniz. Bu sebeple size makrolu çözüm öneriyorum. Ekteki örnek dosyadaki butona tıklayıp sonucu gözlemleyin. İşlem süresi konusunda da bilgi verirseniz sevinirim.

Ben ilk iki sayfada 20.000 kayıt oluşturarak denedim. Benim bilgisayarımda yaklaşık 20 saniyede işlem tamamlanıyor.

Not: Listelenecek kayıt sayısı 65.536 sayısını aşarsa kod hata verir. Eğer böyle bir durum varsa yeni sayfa ekleyerek listeleme yapmak gerekecektir.

Korhan Bey Merhaba,
Dosyayı çalıştırdığımda toplam 13 dakika 21 saniye sürdü fakat listeyi eksik verdi.

Korhan Bey, Listede TC Kimlik numaraları olduğu için listeyi size mail yolu ile göndersem yardımcı olmanız mümkün'müdür.!

Korhan Ayhan · 27 Eylül 2012

Merhaba,

Baya uzun sürmüş...

Dosyayı mail adresime yollayın bakalım...

Korhan Ayhan · 29 Eylül 2012

Merhaba,

Mailime gönderdiğiniz dosyayı inceledim. Bazı TC noları boş. Bunlar hatalı sonuçlar doğurabilir. Aşağıdaki kodu kullanarak işlem süresini büyük ölçüde düşürdüm. Benim bilgisayarımda sonuçların listelenmesi 18 saniye civarında sürüyor.

Kod:

Option Explicit
 
Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet, S4 As Worksheet
    Dim Zaman As Double, SC As Object
    Dim Veri_1 As Variant, Veri_2 As Variant
    Dim Satir As Long, X As Long, Y As Long
    Dim Say_1 As Long, Say_2 As Long
    Dim Sorgu As String, Yeni_Sorgu As String
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
 
    Zaman = Timer
 
    Set S1 = Sheets("Sheet 1")
    Set S2 = Sheets("Sheet 2")
    Set S4 = Sheets("Sheet 4")
 
    S4.Range("A2:D" & Rows.Count).Clear
    S4.Range("D2:D" & Rows.Count).NumberFormat = "#,##0.00"
    S4.Range("A:D").RemoveSubtotal
    S4.Cells.Font.Name = "Tahoma"
 
    Set SC = CreateObject("Scripting.Dictionary")
    SC.CompareMode = vbTextCompare
 
    Satir = Cells(Rows.Count, 1).End(3).Row
    Veri_1 = S1.Range("A2:AK65536").Value
    Veri_2 = S2.Range("A2:AK65536").Value
 
    ReDim Dizi(1 To 37, 1 To UBound(Veri_1))
 
    For X = 1 To UBound(Dizi, 2)
        Sorgu = Veri_1(X, 1) & "#" & Veri_1(X, 2) & "#" & Veri_1(X, 3)
        If Not SC.Exists(Sorgu) Then
            Say_1 = Say_1 + 1
            SC.Add Sorgu, Say_1
            Dizi(1, Say_1) = Veri_1(X, 1)
            Dizi(2, Say_1) = Veri_1(X, 2)
            Dizi(3, Say_1) = Veri_1(X, 3)
        End If
        Dizi(4, SC.Item(Sorgu)) = Dizi(4, SC.Item(Sorgu)) + Veri_1(X, 37)
    Next
 
    ReDim Preserve Dizi(1 To 37, 1 To UBound(Veri_2))
 
    For X = 1 To UBound(Dizi, 2)
        Sorgu = Veri_2(X, 1) & "#" & Veri_2(X, 2) & "#" & Veri_2(X, 3)
        If Not SC.Exists(Sorgu) Then
            Say_1 = Say_1 + 1
            SC.Add Sorgu, Say_1
            Dizi(1, Say_1) = Veri_2(X, 1)
            Dizi(2, Say_1) = Veri_2(X, 2)
            Dizi(3, Say_1) = Veri_2(X, 3)
        End If
        Dizi(4, SC.Item(Sorgu)) = Dizi(4, SC.Item(Sorgu)) + Veri_2(X, 37)
    Next
 
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
 
    If Say_1 > 0 Then
        ReDim Preserve Dizi(1 To 37, 1 To Say_1)
        ReDim Yeni_Dizi(1 To 37, 1 To UBound(Veri_1))
 
        For X = 1 To UBound(Dizi, 2)
            If Dizi(4, X) >= 5000 Then
                Sorgu = Dizi(1, X) & "#" & Dizi(2, X) & "#" & Dizi(3, X)
 
                For Y = 1 To UBound(Yeni_Dizi, 2)
                    Yeni_Sorgu = Veri_1(Y, 1) & "#" & Veri_1(Y, 2) & "#" & Veri_1(Y, 3)
                    If Sorgu = Yeni_Sorgu Then
                        Say_2 = Say_2 + 1
                        ReDim Preserve Yeni_Dizi(1 To 37, 1 To Say_2)
                        Yeni_Dizi(1, Say_2) = Veri_1(Y, 1)
                        Yeni_Dizi(2, Say_2) = Veri_1(Y, 2)
                        Yeni_Dizi(3, Say_2) = Veri_1(Y, 3)
                        Yeni_Dizi(4, Say_2) = Veri_1(Y, 37)
                    End If
                Next
 
                ReDim Preserve Yeni_Dizi(1 To 37, 1 To UBound(Veri_2))
 
                For Y = 1 To UBound(Yeni_Dizi, 2)
                    Yeni_Sorgu = Veri_2(Y, 1) & "#" & Veri_2(Y, 2) & "#" & Veri_2(Y, 3)
                    If Sorgu = Yeni_Sorgu Then
                        Say_2 = Say_2 + 1
                        ReDim Preserve Yeni_Dizi(1 To 37, 1 To Say_2)
                        Yeni_Dizi(1, Say_2) = Veri_2(Y, 1)
                        Yeni_Dizi(2, Say_2) = Veri_2(Y, 2)
                        Yeni_Dizi(3, Say_2) = Veri_2(Y, 3)
                        Yeni_Dizi(4, Say_2) = Veri_2(Y, 37)
                    End If
                Next
            End If
        Next
 
        If Say_2 > 0 Then
            ReDim Preserve Yeni_Dizi(1 To 37, 1 To Say_2)
            Range("A2").Resize(UBound(Yeni_Dizi, 2), 4) = Application.Transpose(Yeni_Dizi)
 
            Range("A2:D65536").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), _
            Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
 
            Range("A:D").RemoveSubtotal
            Range("A1").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4), _
            Replace:=True, PageBreaks:=False, SummaryBelowData:=True
 
            Range("A:D").EntireColumn.AutoFit
            MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
                   "İşlem süresi ; " & Format((Timer - Zaman) / 60 / 60 / 24, "hh:mm:ss.ms"), vbInformation
        Else
            MsgBox "Uygun kayıt bulunamadı!", vbCritical
        End If
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbCritical
    End If
End Sub

_GÜRCAN_ · 1 Ekim 2012

Korhan Ayhan' Alıntı:

Merhaba,

Mailime gönderdiğiniz dosyayı inceledim. Bazı TC noları boş. Bunlar hatalı sonuçlar doğurabilir. Aşağıdaki kodu kullanarak işlem süresini büyük ölçüde düşürdüm. Benim bilgisayarımda sonuçların listelenmesi 12 saniye civarında sürüyor.

Kod:

Option Explicit
 
Sub ÖZET_TABLO()
    Dim S1 As Worksheet, S2 As Worksheet, S4 As Worksheet
    Dim Zaman As Double, SC As Object, Veri_1 As Variant, Veri_2 As Variant
    Dim Satir As Long, X As Long, Say As Long, Sorgu As String
        
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationManual
        
    Zaman = Timer
    
    Set S1 = Sheets("Sheet 1")
    Set S2 = Sheets("Sheet 2")
    Set S4 = Sheets("Sheet 4")
    
    S4.Range("A2:D" & Rows.Count).Clear
    S4.Range("D2:D" & Rows.Count).NumberFormat = "#,##0.00"
    
    Set SC = CreateObject("Scripting.Dictionary")
    SC.CompareMode = vbTextCompare
    
    Satir = Cells(Rows.Count, 1).End(3).Row
    Veri_1 = S1.Range("A2:AK65536").Value
    Veri_2 = S2.Range("A2:AK65536").Value
    
    ReDim Dizi(1 To 37, 1 To UBound(Veri_1))
        
    For X = 1 To UBound(Dizi, 2)
        Sorgu = Veri_1(X, 1) & "#" & Veri_1(X, 2) & "#" & Veri_1(X, 3)
        If Not SC.Exists(Sorgu) Then
            Say = Say + 1
            SC.Add Sorgu, Say
            Dizi(1, Say) = Veri_1(X, 1)
            Dizi(2, Say) = Veri_1(X, 2)
            Dizi(3, Say) = Veri_1(X, 3)
        End If
        Dizi(4, SC.Item(Sorgu)) = Dizi(4, SC.Item(Sorgu)) + Veri_1(X, 37)
    Next
    
    ReDim Preserve Dizi(1 To 37, 1 To UBound(Veri_2))
    
    For X = 1 To UBound(Dizi, 2)
        Sorgu = Veri_2(X, 1) & "#" & Veri_2(X, 2) & "#" & Veri_2(X, 3)
        If Not SC.Exists(Sorgu) Then
            Say = Say + 1
            SC.Add Sorgu, Say
            Dizi(1, Say) = Veri_2(X, 1)
            Dizi(2, Say) = Veri_2(X, 2)
            Dizi(3, Say) = Veri_2(X, 3)
        End If
        Dizi(4, SC.Item(Sorgu)) = Dizi(4, SC.Item(Sorgu)) + Veri_2(X, 37)
    Next
    
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    If Say > 0 Then
        ReDim Preserve Dizi(1 To 37, 1 To Say)
        Range("A2").Resize(UBound(Dizi, 2), 4) = Application.Transpose(Dizi)
        
        Range("A2:D65536").Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), _
        Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
        
        Range("A:D").EntireColumn.AutoFit
        MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
               "İşlem süresi ; " & Format((Timer - Zaman) / 60 / 60 / 24, "hh:mm:ss.ms"), vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbCritical
    End If
End Sub

Korhan Bey Günaydın,
Mailinizi aldım listeleme 5 sn sürüyor. Fakat listeleme de 5000 tl toplam olan kişileri sıralamıyor, desteğinizi rica ediyorum.

iyi çalışmalar dilerim.

Korhan Ayhan · 3 Ekim 2012

Merhaba,

Üstteki mesajımdaki kodu yeniledim. Tekrar denermisiniz. Yeni eklediğimi sorgu ile süre 10 saniye kadar arttı.

Sheet 1 ve Sheet 2 Süzme İşlemi.!

_GÜRCAN_

Ekli dosyalar

RaMeLoT

_GÜRCAN_

sakman26

Ekli dosyalar

_GÜRCAN_

_GÜRCAN_

sakman26

Ekli dosyalar

RaMeLoT

RaMeLoT

Ekli dosyalar

_GÜRCAN_

RaMeLoT

Ekli dosyalar

_GÜRCAN_

_GÜRCAN_

sakman26

Ekli dosyalar

Korhan Ayhan

Administrator

Ekli dosyalar

_GÜRCAN_

Ekli dosyalar

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

_GÜRCAN_

Korhan Ayhan

Administrator